Mercurial > hg > xemacs-beta

comparison lisp/packages/remote.el @ 0:376386a54a3c r19-14

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-14
author cvs
date Mon, 13 Aug 2007 08:45:50 +0200
parents
children
comparison
equal deleted inserted replaced
-1:000000000000 0:376386a54a3c
1 ;; remote.el version 2.6
2 ;;
3 ;; Module to do remote editing via rcp. Assume .rhosts files are
4 ;; set up properly on both machines.
5 ;; Modeled after ftp.el by MLY.PREP.AI.MIT.EDU
6 ;;
7 ;; Nick Tran
8 ;; University of Minnesota
9 ;; Summer 87
10 ;;
11 ;;; Synched up with: Not in FSF.
12
13 ;; Almost complete rewrite. Added minor mode support, better
14 ;; defaults, rewrote find-remote-file, wrote read-remote-file-name,
15 ;; insert-remote-file, find-file, find-alternate-remote-file,
16 ;; get-remote-file-or-buffer, get-remote-buffer, process-wait,
17 ;; remote-rcp-error. Also general clean up, error handling, etc.
18 ;; Eric Raible Wednesday Sept 5, 1988
19 ;;
20 ;; Automatically set major mode, added prefix arg support for most
21 ;; file operations to toggle sense of remote editing.
22 ;; Eric Raible Thursday October 6, 1988
23 ;;
24 ;; Manipulate buffer name more appropriately
25 ;; Eric Raible Friday October 7, 1988
26 ;;
27 ;; For write-remote-file, allow default of file part of remote name.
28 ;; Eric Raible Tuesday October 11, 1988
29
30 (defvar default-remote-host "navier:"
31 "The host to use for remote file operations when none other is appropriate.")
32
33 (defvar track-default-remote-host t
34 "Controls whether default-remote-host is changed after reading a remote file name.
35 When non-nil, default-remote-host will have the value of the last remote host read.")
36
37 (make-variable-buffer-local 'buffer-remote-file-name)
38 (set-default 'buffer-remote-file-name "")
39 (make-variable-buffer-local 'remote-editing)
40
41 (defvar rcp (cond ((file-exists-p "/bin/rcp") "/bin/rcp")
42 ((file-exists-p "/usr/bsd/rcp") "/usr/bsd/rcp")
43 (t "rcp")))
44
45 (if (assoc 'remote-editing minor-mode-alist)
46 ()
47 (setq minor-mode-alist (cons '(remote-editing " Remote") minor-mode-alist)))
48
49 (defun remote-editing (arg)
50 "Toggle remote-editing mode.
51 With arg, turn on remote editing mode iff arg is positive, otherwise just toggle it.
52
53 In remote editing mode, the normal bindings for find-file,
54 find-file-read-only, find-alternate-file, save-buffer, write-file,
55 and insert-file are changed to operate on a remote system by default.
56
57 When remote editing, a prefix arg allows local file operations. When not
58 remote editing, a prefix arg allows remote file operations.
59
60 It is assumed that .rhosts files are set up properly on both machines."
61 (interactive "P")
62 (setq remote-editing
63 (if (null arg) (not remote-editing)
64 (> (prefix-numeric-value arg) 0)))
65 (set-buffer-modified-p (buffer-modified-p))) ;No-op, but updates mode line.
66
67 (global-set-key "\C-xr" 'remote-editing)
68
69 ;;;
70 ;;; Macro used as front-end to normal file operation key bindings to decide between
71 ;;; local and remote modes. Automatically constructs doc string and includes prefix arg
72 ;;; to temporarily toggle sense of remote-editing.
73 ;;;
74 (defmacro def-local-or-remote (binding name remote local)
75 (let ((r (symbol-name (eval remote)))
76 (l (symbol-name (eval local))))
77 (list 'progn
78 (list 'global-set-key binding (list 'quote name))
79 (list 'defun name '(arg)
80 (concat "Call either " r " or " l ".
81 If remote-editing (which see), call " r ", else call " l ".
82
83 See also the documentation for " r " and " l ".")
84 '(interactive "P")
85 (list 'call-interactively
86 (list 'if '(xor remote-editing arg)
87 remote
88 local))))))
89
90 (def-local-or-remote "\C-x\C-f" find-local-or-remote-file 'find-remote-file 'find-file)
91 (def-local-or-remote "\C-x\C-r" find-local-or-remote-file-read-only 'find-remote-file-read-only 'find-file-read-only)
92 (def-local-or-remote "\C-x\C-v" find-alternate-local-or-remote-file 'find-alternate-remote-file 'find-alternate-file)
93 (def-local-or-remote "\C-x\C-s" save-local-or-remote-buffer 'save-remote-buffer 'save-buffer)
94 (def-local-or-remote "\C-x\C-w" write-local-or-remote-file 'write-remote-file 'write-file)
95 (def-local-or-remote "\C-xi" insert-local-or-remote-file 'insert-remote-file 'insert-file)
96
97 (defun find-remote-file (host file)
98 "Edit remote file HOST:FILE (using rcp).
99 This command is similiar to find-file, but uses rcp to read the file from
100 a remote machine. Also see remote-editing."
101 (interactive (read-remote-file-name "Find remote file"))
102 (let ((buffer-or-file (get-remote-file-or-buffer host file "retrieve"))
103 local-file)
104 (if buffer-or-file
105 (if (bufferp buffer-or-file)
106 (switch-to-buffer buffer-or-file)
107 (setq local-file buffer-or-file)
108 (let ((buf (generate-new-buffer
109 (concat host (file-name-nondirectory file)))))
110 (switch-to-buffer buf)
111 (if (not (file-exists-p local-file))
112 (message "(New remote file)")
113 (insert-file-contents local-file)
114 (set-buffer-modified-p nil)
115 (delete-file local-file))
116 ;; dynamic binding for normal-mode
117 (let ((buffer-file-name (concat host file)))
118 (normal-mode)
119 (remote-editing 1)
120 (setq buffer-remote-file-name buffer-file-name
121 buffer-offer-save t)))))))
122
123 (defun find-remote-file-read-only ()
124 "Edit remote file FILENAME, but mark buffer as read-only.
125 Also see find-remote-file and remote-editing."
126 (interactive)
127 (call-interactively 'find-remote-file)
128 (setq buffer-read-only t))
129
130 (defun find-alternate-remote-file ()
131 "Find alternate file using rcp.
132 This command is similiar to find-alternate-file, but uses rcp to read the file from
133 a remote machine. Also see remote-editing."
134 (interactive)
135 (and (buffer-modified-p)
136 (not buffer-read-only)
137 (not (yes-or-no-p (format "Buffer %s is modified; kill anyway? "
138 (buffer-name))))
139 (error "Aborted"))
140 (let ((obuf (current-buffer))
141 (oname (buffer-name)))
142 (rename-buffer " **lose**")
143 (unwind-protect
144 (apply 'find-remote-file
145 (read-remote-file-name "Find remote alternate file"))
146 (if (eq obuf (current-buffer))
147 (rename-buffer oname)
148 (kill-buffer obuf)))))
149
150 (defun save-remote-buffer ()
151 "Save a file using rcp.
152 This command is similiar to save-buffer, but uses rcp to write the file back
153 to a remote machine. Also see remote-editing."
154 (interactive)
155 (if (buffer-modified-p)
156 (if (zerop (length buffer-remote-file-name))
157 (call-interactively 'write-remote-file)
158 (do-write-remote-file buffer-remote-file-name))
159 (message "(No changes need to be saved)")))
160
161 (defun write-remote-file (host file)
162 "Write a file HOST:FILE using rcp.
163 This command is similiar to write-file, but uses rcp to write the file back
164 to a remote machine. Also see remote-editing."
165 (interactive (read-remote-file-name "Write remote file" 'no-file-ok))
166 (do-write-remote-file (concat host file)))
167
168 (defun insert-remote-file (host file)
169 "Insert a remote file HOST:FILE using rcp.
170 This command is similiar to insert-file, but uses rcp to read the file from
171 a remote machine. Also see remote-editing."
172 (interactive (read-remote-file-name "Insert remote file"))
173 (let ((f-or-b (get-remote-file-or-buffer host file "insert")))
174 (if f-or-b
175 (if (bufferp f-or-b)
176 (insert-buffer f-or-b)
177 (insert-file f-or-b)
178 (delete-file f-or-b)))))
179
180 ;;;
181 ;;; Internal routines
182 ;;;
183
184 (defun do-write-remote-file (file)
185 (let* ((temp (concat "/tmp/" (buffer-name)))
186 (output (save-excursion
187 (prog1 (set-buffer (get-buffer-create "*Rcp Output*"))
188 (erase-buffer))))
189 (cursor-in-echo-area t)
190 time)
191 ;; write-file doesn't quite do it.
192 (save-restriction
193 (widen)
194 (write-region (point-min) (point-max) temp nil 'no-message))
195 (message "Sending %s..." file)
196 (if (setq time (process-wait (start-process "rcp" output rcp temp file)))
197 (progn
198 (if remote-editing
199 (let ((new-name (concat (host-part-only file)
200 (file-name-nondirectory (file-part-only file)))))
201 (or (get-buffer new-name) (rename-buffer new-name))
202 (set-buffer-modified-p nil)))
203 (setq buffer-remote-file-name file)
204 (message "%d bytes in %d seconds" (buffer-size) time)
205 (delete-file temp))
206 (remote-rcp-error output buffer-remote-file-name "update"))))
207
208 (defun get-remote-file-or-buffer (host file message)
209 "Return a remote file as either a buffer or a file.
210 If the file HOST:FILE already has been read in, return the buffer
211 that contains it; otherwise try and rcp the file to the local machine.
212 If successful, return the local file name."
213 (let ((remote (concat host file))
214 (temp (concat "/tmp/" (file-name-nondirectory file)))
215 time)
216 (if (string= file (file-name-directory file))
217 (progn
218 (message "Remote directory listing not yet implemented")
219 nil)
220 (or (get-remote-buffer remote) ;; already exists
221 (let* ((output (save-excursion
222 (prog1 (set-buffer (get-buffer-create "*Rcp Output*"))
223 (erase-buffer))))
224 (cursor-in-echo-area t))
225 (message "Retrieving %s..." remote)
226 (if (setq time (process-wait (start-process "rcp" output rcp remote temp)))
227 (progn
228 (message "%d bytes in %d seconds"
229 (nth 7 (file-attributes temp)) time)
230 temp)
231 (remote-rcp-error output remote message)))))))
232
233 (defun get-remote-buffer (name)
234 (save-window-excursion
235 (let ((buffers (buffer-list)) found)
236 (while (and (not found) buffers)
237 (set-buffer (car buffers))
238 (if (string= name buffer-remote-file-name)
239 (setq found (car buffers)))
240 (setq buffers (cdr buffers)))
241 found)))
242
243 (defun read-remote-file-name (prompt &optional no-file-ok)
244 "Read a remote file specification, and return list (host file).
245 Prompting with PROMPT, read a string of the form host:file. The default
246 value is derived from the remote file name, or if there is none, then
247 from the global default (default-remote-host)."
248 (let* ((host (or (host-part-only buffer-remote-file-name)
249 default-remote-host))
250 (result (concat host (file-name-directory
251 (or (file-part-only buffer-remote-file-name)
252 ""))))
253 (prompt (concat prompt " (host:file): "))
254 file)
255 (setq result (read-no-blanks-input prompt result))
256 (while (not (string-match (if no-file-ok
257 ".+:"
258 ".+:.+")
259 result))
260 (setq result (read-no-blanks-input prompt result)))
261 (setq host (host-part-only result)
262 file (file-part-only result))
263 (and track-default-remote-host
264 (setq default-remote-host host))
265 (list host
266 (if (or (null file) (string= file (file-name-directory file)))
267 (concat file (or (if (not (string= buffer-remote-file-name ""))
268 (file-name-nondirectory
269 (file-part-only buffer-remote-file-name)))
270 (file-part-only (buffer-name))
271 (buffer-name)))
272 file))))
273
274 (defun host-part-only (name)
275 (if (string-match ".+:" name)
276 (substring name 0 (match-end 0))))
277
278 (defun file-part-only (name)
279 (if (string-match ".+:\\(.+\\)" name)
280 (substring name (match-beginning 1) (match-end 1))))
281
282 (defun xor (a b)
283 (eq (null a) (not (null b))))
284
285 (defun process-wait (proc)
286 (let ((time 0))
287 (while (eq (process-status proc) 'run)
288 (setq time (1+ time))
289 (sleep-for 1))
290 (if (and (eq (process-status proc) 'exit)
291 (eq (process-exit-status proc) 0))
292 time
293 nil)))
294
295 (defun remote-rcp-error (buffer file-name message)
296 (save-window-excursion
297 (switch-to-buffer buffer)
298 (delete-other-windows)
299 (goto-char 1)
300 (insert (format "Unable to %s %s\n\n" message file-name))
301 (goto-char (point-max))
302 (message "Hit any character to continue")
303 (read-char)
304 (bury-buffer buffer)))