Mercurial > hg > xemacs-beta

comparison lisp/w3/url-gw.el @ 16:0293115a14e9 r19-15b91

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b91
author cvs
date Mon, 13 Aug 2007 08:49:20 +0200
parents
children 859a2309aef8 0d2f883870bc
comparison
equal deleted inserted replaced
15:ad457d5f7d04 16:0293115a14e9
1 ;;; url-gw.el --- Gateway munging for URL loading
2 ;; Author: wmperry
3 ;; Created: 1997/01/16 14:17:34
4 ;; Version: 1.3
5 ;; Keywords: comm, data, processes
6
7 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
8 ;;; Copyright (c) 1997 Free Software Foundation, Inc.
9 ;;;
10 ;;; This file is not part of GNU Emacs, but the same permissions apply.
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 (require 'cl)
28
29 (defvar url-gateway-local-host-regexp nil
30 "*A regular expression specifying local hostnames/machines.")
31
32 (defvar url-gateway-prompt-pattern
33 "^[^#$%>;]*[#$%>;] *" ;; "bash\\|\$ *\r?$\\|> *\r?"
34 "*A regular expression matching a shell prompt.")
35
36 (defvar url-gateway-rlogin-host nil
37 "*What hostname to actually rlog into before doing a telnet.")
38
39 (defvar url-gateway-rlogin-user-name nil
40 "*Username to log into the remote machine with when using rlogin.")
41
42 (defvar url-gateway-rlogin-parameters '("telnet" "-8")
43 "*Parameters to `url-open-rlogin'.
44 This list will be used as the parameter list given to rsh.")
45
46 (defvar url-gateway-telnet-host nil
47 "*What hostname to actually login to before doing a telnet.")
48
49 (defvar url-gateway-telnet-parameters '("exec" "telnet" "-8")
50 "*Parameters to `url-open-telnet'.
51 This list will be executed as a command after logging in via telnet.")
52
53 (defvar url-gateway-telnet-login-prompt "^\r*.?login:"
54 "*Prompt that tells us we should send our username when loggin in w/telnet.")
55
56 (defvar url-gateway-telnet-password-prompt "^\r*.?password:"
57 "*Prompt that tells us we should send our password when loggin in w/telnet.")
58
59 (defvar url-gateway-telnet-user-name nil
60 "User name to log in via telnet with.")
61
62 (defvar url-gateway-telnet-password nil
63 "Password to use to log in via telnet with.")
64
65 (defvar url-gateway-broken-resolution nil
66 "*Whether to use nslookup to resolve hostnames.
67 This should be used when your version of Emacs cannot correctly use DNS,
68 but your machine can. This usually happens if you are running a statically
69 linked Emacs under SunOS 4.x")
70
71 (defvar url-gateway-nslookup-program nil
72 "*If non-NIL then a string naming nslookup program." )
73
74 ;; Stolen from ange-ftp
75 (defun url-gateway-nslookup-host (host)
76 "Attempt to resolve the given HOSTNAME using nslookup if possible."
77 (interactive "sHost: ")
78 (if url-gateway-nslookup-program
79 (let ((proc (start-process " *nslookup*" " *nslookup*"
80 url-gateway-nslookup-program host))
81 (res host))
82 (process-kill-without-query proc)
83 (save-excursion
84 (set-buffer (process-buffer proc))
85 (while (memq (process-status proc) '(run open))
86 (accept-process-output proc))
87 (goto-char (point-min))
88 (if (re-search-forward "Name:.*\nAddress: *\\(.*\\)$" nil t)
89 (setq res (buffer-substring (match-beginning 1)
90 (match-end 1))))
91 (kill-buffer (current-buffer)))
92 res)
93 host))
94
95 ;; Stolen from red gnus nntp.el
96 (defun url-wait-for-string (regexp proc)
97 "Wait until string arrives in the buffer."
98 (let ((buf (current-buffer)))
99 (goto-char (point-min))
100 (while (not (re-search-forward regexp nil t))
101 (accept-process-output proc)
102 (set-buffer buf)
103 (goto-char (point-min)))))
104
105 ;; Stolen from red gnus nntp.el
106 (defun url-open-rlogin (name buffer host service)
107 "Open a connection using rsh."
108 (if (not (stringp service))
109 (setq service (into-to-string service)))
110 (let ((proc (if url-gateway-rlogin-user-name
111 (start-process
112 name buffer "rsh"
113 url-gateway-rlogin-host "-l" url-gateway-rlogin-user-name
114 (mapconcat 'identity
115 (append url-gateway-rlogin-parameters
116 (list host service)) " "))
117 (start-process
118 name buffer "rsh" url-gateway-rlogin-host
119 (mapconcat 'identity
120 (append url-gateway-rlogin-parameters
121 (list host service))
122 " ")))))
123 (set-buffer buffer)
124 (url-wait-for-string "^\r*200" proc)
125 (beginning-of-line)
126 (delete-region (point-min) (point))
127 proc))
128
129 ;; Stolen from red gnus nntp.el
130 (defun url-open-telnet (name buffer host service)
131 (if (not (stringp service))
132 (setq service (into-to-string service)))
133 (save-excursion
134 (set-buffer (get-buffer-create buffer))
135 (erase-buffer)
136 (let ((proc (start-process name buffer "telnet" "-8"))
137 (case-fold-search t))
138 (when (memq (process-status proc) '(open run))
139 (process-send-string proc "set escape \^X\n")
140 (process-send-string proc (concat
141 "open " url-gateway-telnet-host "\n"))
142 (url-wait-for-string url-gateway-telnet-login-prompt proc)
143 (process-send-string
144 proc (concat
145 (or url-gateway-telnet-user-name
146 (setq url-gateway-telnet-user-name (read-string "login: ")))
147 "\n"))
148 (url-wait-for-string url-gateway-telnet-password-prompt proc)
149 (process-send-string
150 proc (concat
151 (or url-gateway-telnet-password
152 (setq url-gateway-telnet-password
153 (funcall url-passwd-entry-func "Password: ")))
154 "\n"))
155 (erase-buffer)
156 (url-wait-for-string url-gateway-prompt-pattern proc)
157 (process-send-string
158 proc (concat (mapconcat 'identity
159 (append url-gateway-telnet-parameters
160 (list host service)) " ") "\n"))
161 (url-wait-for-string "^\r*Escape character.*\r*\n+" proc)
162 (delete-region (point-min) (match-end 0))
163 (process-send-string proc "\^]\n")
164 (url-wait-for-string "^telnet" proc)
165 (process-send-string proc "mode character\n")
166 (accept-process-output proc 1)
167 (sit-for 1)
168 (goto-char (point-min))
169 (forward-line 1)
170 (delete-region (point) (point-max)))
171 proc)))
172
173 ;;###autoload
174 (defun url-open-stream (name buffer host service)
175 "Open a stream to a host"
176 (let ((gw-method (if (and url-gateway-local-host-regexp
177 (not (eq 'ssl url-gateway-method))
178 (string-match
179 url-gateway-local-host-regexp
180 host))
181 'native
182 url-gateway-method))
183 ;; This hack is for OS/2 Emacs so that it will not do bogus CRLF
184 ;; conversions while trying to be 'helpful'
185 (tcp-binary-process-output-services (if (stringp service)
186 (list service)
187 (list service
188 (int-to-string service))))
189
190 ;; An attempt to deal with denied connections, and attempt to reconnect
191 (max-retries url-connection-retries)
192 (cur-retries 0)
193 (retry t)
194 (errobj nil)
195 (conn nil))
196
197 ;; If the user told us to do DNS for them, do it.
198 (if url-gateway-broken-resolution
199 (setq host (url-nslookup-host host)))
200
201 (while (and (not conn) retry)
202 (condition-case errobj
203 (setq conn (case gw-method
204 (ssl
205 (open-ssl-stream name buffer host service))
206 ((tcp native)
207 (and (eq 'tcp gw-method) (require 'tcp))
208 (open-network-stream name buffer host service))
209 (socks
210 (socks-open-network-stream name buffer host service))
211 (telnet
212 (url-open-telnet name buffer host service))
213 (rlogin
214 (url-open-rlogin name buffer host service))
215 (otherwise
216 (error "Bad setting of url-gateway-method: %s"
217 url-gateway-method))))
218 (error
219 (url-save-error errobj)
220 (save-window-excursion
221 (save-excursion
222 (switch-to-buffer-other-window " *url-error*")
223 (shrink-window-if-larger-than-buffer)
224 (goto-char (point-min))
225 (if (and (re-search-forward "in use" nil t)
226 (< cur-retries max-retries))
227 (progn
228 (setq retry t
229 cur-retries (1+ cur-retries))
230 (sleep-for 0.5))
231 (setq cur-retries 0
232 retry (funcall url-confirmation-func
233 (concat "Connection to " host
234 " failed, retry? "))))
235 (kill-buffer (current-buffer)))))))
236 (if (not conn)
237 (error "Unable to connect to %s:%s" host service)
238 (mule-inhibit-code-conversion conn)
239 conn)))
240
241 (provide 'url-gw)