Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-cms.el @ 98:0d2f883870bc r20-1b1

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r20-1b1
author cvs
date Mon, 13 Aug 2007 09:13:56 +0200
parents 8fc7fe29b841
children 7e54bd776075 9f59509498e1
comparison
equal deleted inserted replaced
97:498bf5da1c90 98:0d2f883870bc
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-cms.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.1 $
7 ;; RCS:
8 ;; Description: CMS support for efs
9 ;; Author: Sandy Rutherford <sandy@ibm550.sissa.it>
10 ;; Created: Fri Oct 23 08:52:00 1992
11 ;; Modified: Sun Nov 27 11:46:51 1994 by sandy on gandalf
12 ;; Language: Emacs-Lisp
13 ;;
14 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
15
16 ;;; This file is part of efs. See efs.el for copyright
17 ;;; (it's copylefted) and warrranty (there isn't one) information.
18
19 (provide 'efs-cms)
20 (require 'efs)
21
22 (defconst efs-cms-version
23 (concat (substring "$efs release: 1.15 $" 14 -2)
24 "/"
25 (substring "$Revision: 1.1 $" 11 -2)))
26
27 ;;;; ------------------------------------------------------------
28 ;;;; CMS support
29 ;;;; ------------------------------------------------------------
30
31 ;;; efs has full support, including tree dired support, for hosts running
32 ;;; CMS. It should be able to automatically recognize any CMS machine.
33 ;;; We would be grateful if you would report any failures to automatically
34 ;;; recognize a CMS host as a bug.
35 ;;;
36 ;;; This should also work with CMS machines running SFS (Shared File System).
37 ;;;
38 ;;; Filename syntax:
39 ;;;
40 ;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are
41 ;;; treated as UNIX directories. For example to access the file READ.ME in
42 ;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter
43 ;;; /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME
44 ;;; If *.301 is the default minidisk for this account, you could access
45 ;;; FOO.BAR on this minidisk as
46 ;;; /anonymous@cuvmb.cc.columbia.edu:FOO.BAR
47 ;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be
48 ;;; up to 8 characters. Again, beware that CMS filenames are always upper
49 ;;; case, and hence must be entered as such.
50 ;;;
51 ;;; Tips:
52 ;;; 1. CMS machines, with the exception of anonymous accounts, nearly always
53 ;;; need an account password. To have efs send an account password,
54 ;;; you can either include it in your .netrc file, or use
55 ;;; efs-set-account.
56 ;;; 2. efs-set-account can be used to set account passwords for specific
57 ;;; minidisks. This is usually used to optain write access to the minidisk.
58 ;;; As well you can put tokens of the form
59 ;;; minidisk <minidisk name> <password> in your .netrc file. There can be
60 ;;; as many minidisk tokens as you like, however they should follow all
61 ;;; other tokens for a given machine entry. Of course, ordinary ftp
62 ;;; will not understand these entries in your .netrc file.
63 ;;;
64
65
66 ;;; Since CMS doesn't have any full pathname syntax, we have to fudge
67 ;;; things with cd's. We actually send too many cd's, but is dangerous
68 ;;; to try to remember the current minidisk, because if the connection
69 ;;; is closed and needs to be reopened, we will find ourselves back in
70 ;;; the default minidisk. This is fairly likely since CMS ftp servers
71 ;;; usually close the connection after 5 minutes of inactivity.
72
73 ;;; Have I got the filename character set right?
74
75 ;;; The following three functions are entry points to this file.
76 ;;; They have been added to the appropriate alists in efs.el
77
78 (efs-defun efs-fix-path cms (path &optional reverse)
79 ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert
80 ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax,
81 ;; so we fudge things by sending cd's.
82 (efs-save-match-data
83 (if reverse
84 (if (string-match ":" path)
85 ;; It's SFS
86 (let* ((start (match-end 0))
87 (return (concat "/" (substring path 0 start))))
88 (while (string-match "\\." path start)
89 (setq return (concat return "/"
90 (substring path start
91 (match-beginning 0)))
92 start (match-end 0)))
93 (concat return "/" (substring path start)))
94 ;; Since we only convert output from a pwd in this direction,
95 ;; we'll assume that it's a minidisk, and make it into a
96 ;; directory file name. Note that the expand-dir-hashtable
97 ;; stores directories without the trailing /.
98 (if (char-equal (string-to-char path) ?/)
99 path
100 (concat "/" path)))
101 (if (let ((case-fold-search t))
102 (string-match
103 (concat
104 "^/\\([-A-Z0-9$*._+:]+\\)/"
105 ;; In case there is a SFS
106 "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?"
107 "\\([-A-Z0-9$._+]+\\)$")
108 path))
109 (let ((minidisk (substring path 1 (match-end 1)))
110 (sfs (and (match-beginning 2)
111 (substring path (match-beginning 3)
112 (match-end 3))))
113 (file (substring path (match-beginning 5) (match-end 5)))
114 account)
115 (and sfs (match-beginning 4)
116 (setq sfs (concat sfs "." (substring path (match-beginning 4)
117 (1- (match-end 4))))))
118 (unwind-protect
119 (progn
120 (or sfs
121 (setq account
122 (efs-get-account host user minidisk)))
123 (efs-raw-send-cd host user (if sfs
124 (concat minidisk sfs ".")
125 minidisk))
126 (if account
127 (efs-cms-send-minidisk-acct
128 host user minidisk account)))
129 (if account (fillarray account 0)))
130 file)
131 (error "Invalid CMS filename")))))
132
133 (efs-defun efs-fix-dir-path cms (dir-path)
134 ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing.
135 (efs-save-match-data
136 (cond
137 ((string-equal "/" dir-path)
138 (error "Cannot get listing for CMS \"/\" directory."))
139 ((let ((case-fold-search t))
140 (string-match
141 (concat "^/\\([-A-Z0-9$*._+:]+\\)/"
142 "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?"
143 "\\([-A-Z0-9$*_.+]+\\)?$") dir-path))
144 (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1)))
145 (sfs (and (match-beginning 2)
146 (concat
147 (substring dir-path (match-beginning 3)
148 (match-end 3)))))
149 (file (if (match-beginning 5)
150 (substring dir-path (match-beginning 5) (match-end 5))
151 "*"))
152 account)
153 (and sfs (match-beginning 4)
154 (setq sfs (concat sfs "." (substring dir-path
155 (match-beginning 4)
156 (1- (match-end 4))))))
157 (unwind-protect
158 (progn
159 (or sfs
160 (setq account (efs-get-account host user minidisk)))
161 (efs-raw-send-cd host user (if sfs
162 (concat minidisk sfs ".")
163 minidisk))
164 (if account
165 (efs-cms-send-minidisk-acct host user minidisk account)))
166 (if account (fillarray account 0)))
167 file))
168 (t (error "Invalid CMS pathname")))))
169
170 (defconst efs-cms-file-line-regexp
171 (concat
172 "\\([-A-Z0-9$_+]+\\) +"
173 "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)"))
174
175 (efs-defun efs-parse-listing cms
176 (host user dir path &optional switches)
177 ;; Parse the current buffer which is assumed to be a CMS directory listing.
178 ;; HOST = remote host name
179 ;; USER = remote user name
180 ;; DIR = directory as a full remote path
181 ;; PATH = directory as a full efs-path
182 (let ((tbl (efs-make-hashtable))
183 fn dir-p)
184 (goto-char (point-min))
185 (efs-save-match-data
186 (while (re-search-forward efs-cms-file-line-regexp nil t)
187 (if (match-beginning 3)
188 (setq fn (concat (buffer-substring
189 (match-beginning 1) (match-end 1))
190 "."
191 (buffer-substring
192 (match-beginning 4) (match-end 4)))
193 dir-p nil)
194 (setq fn (buffer-substring (match-beginning 1) (match-end 1))
195 dir-p t))
196 (efs-put-hash-entry fn (list dir-p) tbl)
197 (forward-line 1))
198 (efs-put-hash-entry "." '(t) tbl)
199 (efs-put-hash-entry ".." '(t) tbl))
200 tbl))
201
202 (defun efs-cms-send-minidisk-acct (host user minidisk account
203 &optional noretry)
204 "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given,
205 the account password is for that minidisk. If PROC is given, send to that
206 process, rathr than use HOST and USER to look up the process."
207 (efs-save-match-data
208 (let ((result (efs-raw-send-cmd
209 (efs-get-process host user)
210 (concat "quote acct " account))))
211 (cond
212 ((eq (car result) 'failed)
213 (setq account nil)
214 (unwind-protect
215 (progn
216 (setq
217 account
218 (read-passwd
219 (format
220 "Invalid acct. password for %s on %s@%s. Try again: "
221 minidisk user host)))
222 (if (string-equal "" account)
223 (setq account nil)))
224 ;; This guarantees that an interrupt will clear the account
225 ;; password.
226 (efs-set-account host user minidisk account))
227 (if account ; give the user another chance
228 (efs-cms-send-minidisk-acct host user minidisk account)))
229 ((eq (car result) 'fatal)
230 (if noretry
231 ;; give up
232 (efs-error host user
233 (concat "ACCOUNT password failed: " (nth 1 result)))
234 ;; try once more
235 (efs-cms-send-minidisk-acct host user minidisk account t))))
236 ;; return result
237 result)))
238
239 (efs-defun efs-write-recover cms
240 (line cont-lines host user cmd msg pre-cont cont nowait noretry)
241 ;; If a write fails because of insufficient privileges, give the user a
242 ;; chance to send an account password.
243 (let ((cmd0 (car cmd))
244 (cmd1 (nth 1 cmd))
245 (cmd2 (nth 2 cmd)))
246 (efs-save-match-data
247 (if (and (or (memq cmd0 '(append put rename))
248 (and (eq cmd0 'quote) (eq cmd1 'stor)))
249 (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2))
250 (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1)))
251 account retry)
252 (unwind-protect
253 (progn
254 (setq account
255 (read-passwd
256 (format "Account password for minidisk %s on %s@%s: "
257 minidisk user host)))
258 (if (string-equal account "")
259 (setq account nil)))
260 (efs-set-account host user minidisk account))
261 (if account
262 (progn
263 (efs-cms-send-minidisk-acct host user minidisk account)
264 (setq retry
265 (efs-send-cmd host user cmd msg pre-cont cont
266 nowait noretry))
267 (and (null (or cont nowait)) retry))
268 (if cont
269 (progn
270 (efs-call-cont cont 'failed line cont-lines)
271 nil)
272 (and (null nowait) (list 'failed line cont-lines)))))
273 (if cont
274 (progn
275 (efs-call-cont cont 'failed line cont-lines)
276 nil)
277 (and (null nowait) (list 'failed line cont-lines)))))))
278
279 (efs-defun efs-allow-child-lookup cms (host user dir file)
280 ;; Returns t if FILE in directory DIR could possibly be a subdir
281 ;; according to its file-name syntax, and therefore a child listing should
282 ;; be attempted.
283
284 ;; CMS file system is flat. Only minidisks are "subdirs".
285 (or (string-equal "/" dir)
286 (efs-save-match-data
287 (string-match "^/[^/:]+:/$" dir))))
288
289 ;;; Sorting listings
290
291 (defconst efs-cms-date-and-time-regexp
292 (concat
293 " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +"
294 "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) "))
295
296 (efs-defun efs-t-converter cms (&optional regexp reverse)
297 (if regexp
298 nil
299 (goto-char (point-min))
300 (efs-save-match-data
301 (if (re-search-forward efs-cms-date-and-time-regexp nil t)
302 (let (list-start list bol nbol)
303 (beginning-of-line)
304 (setq list-start (point))
305 (while (progn
306 (setq bol (point))
307 (re-search-forward efs-cms-date-and-time-regexp
308 (setq nbol (save-excursion
309 (forward-line 1) (point)))
310 t))
311 (setq list
312 (cons
313 (cons
314 (list (string-to-int (buffer-substring
315 (match-beginning 3)
316 (match-end 3))) ; year
317 (string-to-int (buffer-substring
318 (match-beginning 1)
319 (match-end 1))) ; month
320 (string-to-int (buffer-substring
321 (match-beginning 2)
322 (match-end 2))) ; day
323 (string-to-int (buffer-substring
324 (match-beginning 4)
325 (match-end 4))) ; hour
326 (string-to-int (buffer-substring
327 (match-beginning 5)
328 (match-end 5))) ; minutes
329 (string-to-int (buffer-substring
330 (match-beginning 6)
331 (match-end 6)))) ; seconds
332 (buffer-substring bol nbol))
333 list))
334 (goto-char nbol))
335 (if list
336 (progn
337 (setq list
338 (mapcar 'cdr
339 (sort list 'efs-cms-t-converter-sort-pred)))
340 (if reverse (setq list (nreverse list)))
341 (delete-region list-start (point))
342 (apply 'insert list)))
343 t)))))
344
345 (defun efs-cms-t-converter-sort-pred (elt1 elt2)
346 (let* ((data1 (car elt1))
347 (data2 (car elt2))
348 (year1 (car data1))
349 (year2 (car data2))
350 (month1 (nth 1 data1))
351 (month2 (nth 1 data2))
352 (day1 (nth 2 data1))
353 (day2 (nth 2 data2))
354 (hour1 (nth 3 data1))
355 (hour2 (nth 3 data2))
356 (minute1 (nth 4 data1))
357 (minute2 (nth 4 data2))
358 (second1 (nth 5 data1))
359 (second2 (nth 5 data2)))
360 (or (> year1 year2)
361 (and (= year1 year2)
362 (or (> month1 month2)
363 (and (= month1 month2)
364 (or (> day1 day2)
365 (and (= day1 day2)
366 (or (> hour1 hour2)
367 (and (= hour1 hour2)
368 (or (> minute1 minute2)
369 (and (= minute1 minute2)
370 (or (> (nth 5 data1)
371 (nth 5 data2)))
372 ))))))))))))
373
374
375 ;;; Tree dired support:
376
377 (defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ")
378
379 (or (assq 'cms efs-dired-re-exe-alist)
380 (setq efs-dired-re-exe-alist
381 (cons (cons 'cms efs-dired-cms-re-exe)
382 efs-dired-re-exe-alist)))
383
384 (defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ")
385
386 (or (assq 'cms efs-dired-re-dir-alist)
387 (setq efs-dired-re-dir-alist
388 (cons (cons 'cms efs-dired-cms-re-dir)
389 efs-dired-re-dir-alist)))
390
391 (efs-defun efs-dired-insert-headerline cms (dir)
392 ;; CMS has no total line, so we insert a blank line for
393 ;; aesthetics.
394 (insert "\n")
395 (forward-char -1)
396 (efs-real-dired-insert-headerline dir))
397
398 (efs-defun efs-dired-manual-move-to-filename cms
399 (&optional raise-error bol eol)
400 ;; In dired, move to the first char of filename on this line.
401 ;; This is the CMS version.
402 (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
403 (let (case-fold-search)
404 (if bol
405 (goto-char bol)
406 (skip-chars-backward "^\n\r")
407 (setq bol (point)))
408 (if (re-search-forward efs-cms-file-line-regexp eol t)
409 (goto-char (match-beginning 0))
410 (goto-char bol)
411 (and raise-error (error "No file on this line")))))
412
413 (efs-defun efs-dired-manual-move-to-end-of-filename cms
414 (&optional no-error bol eol)
415 ;; Assumes point is at beginning of filename.
416 ;; So, it should be called only after (dired-move-to-filename t).
417 ;; case-fold-search must be nil, at least for VMS.
418 ;; On failure, signals an error or returns nil.
419 ;; This is the CMS version.
420 (let ((opoint (point)))
421 (and selective-display
422 (null no-error)
423 (eq (char-after
424 (1- (or bol (save-excursion
425 (skip-chars-backward "^\r\n")
426 (point)))))
427 ?\r)
428 ;; File is hidden or omitted.
429 (cond
430 ((dired-subdir-hidden-p (dired-current-directory))
431 (error
432 (substitute-command-keys
433 "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
434 ((error
435 (substitute-command-keys
436 "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
437 )))))
438 (skip-chars-forward "-A-Z0-9$_+")
439 (or (looking-at " +DIR ")
440 (progn
441 (skip-chars-forward " ")
442 (skip-chars-forward "-A-Z0-9$_+")))
443 (if (or (= opoint (point)) (/= (following-char) ?\ ))
444 (if no-error
445 nil
446 (error "No file on this line"))
447 (point))))
448
449 (efs-defun efs-dired-make-filename-string cms (filename &optional reverse)
450 (if reverse
451 (if (string-match "\\." filename)
452 ;; Can't count on the number of blanks between the base and the
453 ;; extension, so ignore the extension.
454 (substring filename 0 (match-beginning 0))
455 filename)
456 (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename)
457 (concat (substring filename 0 (match-end 1))
458 "."
459 (substring filename (match-beginning 2) (match-end 2)))
460 filename)))
461
462 ;;; end of efs-cms.el