|
22
|
1 ;; -*-Emacs-Lisp-*-
|
|
|
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
3 ;;
|
|
|
4 ;; File: efs-vms.el
|
|
|
5 ;; Release: $efs release: 1.15 $
|
|
42
|
6 ;; Version: #Revision: 1.13 $
|
|
22
|
7 ;; RCS:
|
|
|
8 ;; Description: VMS support for efs
|
|
|
9 ;; Authors: Andy Norman, Joe Wells, Sandy Rutherford <sandy@itp.ethz.ch>
|
|
|
10 ;; Modified: Sun Nov 27 18:44:59 1994 by sandy on gandalf
|
|
|
11 ;;
|
|
|
12 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
13
|
|
|
14 ;;; This file is part of efs. See efs.el for copyright
|
|
|
15 ;;; (it's copylefted) and warrranty (there isn't one) information.
|
|
|
16
|
|
|
17 (provide 'efs-vms)
|
|
|
18 (require 'efs)
|
|
|
19
|
|
|
20 (defconst efs-vms-version
|
|
|
21 (concat (substring "$efs release: 1.15 $" 14 -2)
|
|
|
22 "/"
|
|
42
|
23 (substring "#Revision: 1.13 $" 11 -2)))
|
|
22
|
24
|
|
|
25 ;;;; ------------------------------------------------------------
|
|
|
26 ;;;; VMS support.
|
|
|
27 ;;;; ------------------------------------------------------------
|
|
|
28
|
|
|
29 ;;; efs has full support for VMS hosts, including tree dired support. It
|
|
|
30 ;;; should be able to automatically recognize any VMS machine. However, if it
|
|
|
31 ;;; fails to do this, you can use the command efs-add-vms-host. As well,
|
|
|
32 ;;; you can set the variable efs-vms-host-regexp in your .emacs file. We
|
|
|
33 ;;; would be grateful if you would report any failures to automatically
|
|
|
34 ;;; recognize a VMS host as a bug.
|
|
|
35 ;;;
|
|
|
36 ;;; Filename Syntax:
|
|
|
37 ;;;
|
|
|
38 ;;; For ease of *implementation*, the user enters the VMS filename syntax in a
|
|
|
39 ;;; UNIX-y way. For example:
|
|
|
40 ;;; PUB$:[ANONYMOUS.SDSCPUB.NEXT]README.TXT;1
|
|
|
41 ;;; would be entered as:
|
|
|
42 ;;; /PUB$$:/ANONYMOUS/SDSCPUB/NEXT/README.TXT;1
|
|
|
43 ;;; i.e. to log in as anonymous on ymir.claremont.edu and grab the file:
|
|
|
44 ;;; [.CSV.POLICY]RULES.MEM
|
|
|
45 ;;; you would type:
|
|
|
46 ;;; C-x C-f /anonymous@ymir.claremont.edu:CSV/POLICY/RULES.MEM
|
|
|
47 ;;;
|
|
|
48 ;;; A legal VMS filename is of the form: FILE.TYPE;##
|
|
|
49 ;;; where FILE can be up to 39 characters
|
|
|
50 ;;; TYPE can be up to 39 characters
|
|
|
51 ;;; ## is a version number (an integer between 1 and 32,767)
|
|
|
52 ;;; Valid characters in FILE and TYPE are A-Z 0-9 _ - $
|
|
|
53 ;;; $ cannot begin a filename, and - cannot be used as the first or last
|
|
|
54 ;;; character.
|
|
|
55 ;;;
|
|
|
56 ;;; Tips:
|
|
|
57 ;;; 1. To access the latest version of file under VMS, you use the filename
|
|
|
58 ;;; without the ";" and version number. You should always edit the latest
|
|
|
59 ;;; version of a file. If you want to edit an earlier version, copy it to a
|
|
|
60 ;;; new file first. This has nothing to do with efs, but is simply
|
|
|
61 ;;; good VMS operating practice. Therefore, to edit FILE.TXT;3 (say 3 is
|
|
|
62 ;;; latest version), do C-x C-f /ymir.claremont.edu:FILE.TXT. If you
|
|
|
63 ;;; inadvertently do C-x C-f /ymir.claremont.edu:FILE.TXT;3, you will find
|
|
|
64 ;;; that VMS will not allow you to save the file because it will refuse to
|
|
|
65 ;;; overwrite FILE.TXT;3, but instead will want to create FILE.TXT;4, and
|
|
|
66 ;;; attach the buffer to this file. To get out of this situation, M-x
|
|
|
67 ;;; write-file /ymir.claremont.edu:FILE.TXT will attach the buffer to
|
|
|
68 ;;; latest version of the file. For this reason, in tree dired "f"
|
|
|
69 ;;; (dired-find-file), always loads the file sans version, whereas "v",
|
|
|
70 ;;; (dired-view-file), always loads the explicit version number. The
|
|
|
71 ;;; reasoning being that it reasonable to view old versions of a file, but
|
|
|
72 ;;; not to edit them.
|
|
|
73 ;;; 2. EMACS has a feature in which it does environment variable substitution
|
|
|
74 ;;; in filenames. Therefore, to enter a $ in a filename, you must quote it
|
|
|
75 ;;; by typing $$. There is a bug in EMACS, in that it neglects to quote the
|
|
|
76 ;;; $'s in the default directory when it writes it in the minibuffer. You
|
|
|
77 ;;; must edit the minibuffer to quote the $'s manually. Hopefully, this bug
|
|
|
78 ;;; will be fixed in EMACS 19. If you use Sebastian Kremer's gmhist (V 4.26
|
|
|
79 ;;; or newer), you will not have this problem.
|
|
|
80
|
|
|
81
|
|
|
82 ;; Because some VMS ftp servers convert filenames to lower case
|
|
|
83 ;; we allow a-z in the filename regexp.
|
|
|
84
|
|
|
85 (defconst efs-vms-filename-regexp
|
|
|
86 "\\([_A-Za-z0-9$][-_A-Za-z0-9$]*\\)?\\.\\([-_A-Za-z0-9$]*\\);[0-9]+")
|
|
|
87 ;; Regular expression to match for a valid VMS file name in Dired buffer.
|
|
|
88
|
|
|
89 (defvar efs-vms-month-alist
|
|
|
90 '(("JAN" . 1) ("FEB". 2) ("MAR" . 3) ("APR" . 4) ("MAY" . 5) ("JUN" . 6)
|
|
|
91 ("JUL" . 7) ("AUG" . 8) ("SEP" . 9) ("OCT" . 10)
|
|
|
92 ("NOV" . 11) ("DEC" . 12)))
|
|
|
93
|
|
|
94 (defvar efs-vms-date-regexp
|
|
|
95 (concat
|
|
|
96 "\\([0-3]?[0-9]\\)-"
|
|
|
97 "\\(JAN\\|FEB\\|MAR\\|APR\\|MAY\\|JUN\\|"
|
|
|
98 "JUL\\|AUG\\|SEP\\|OCT\\|NOV\\|DEC\\)-"
|
|
|
99 "\\([0-9][0-9][0-9]?[0-9]?\\) \\(\\([0-5][0-9]\\):\\([0-5][0-9]\\)"
|
|
|
100 "\\(:[0-5][0-9]\\)?\\)? "))
|
|
|
101
|
|
|
102
|
|
|
103 ;;; The following two functions are entry points to this file.
|
|
|
104 ;;; They are defined as efs-autoloads in efs.el
|
|
|
105
|
|
|
106 (efs-defun efs-fix-path vms (path &optional reverse)
|
|
|
107 ;; Convert PATH from UNIX-ish to VMS.
|
|
|
108 ;; If REVERSE given then convert from VMS to UNIX-ish.
|
|
|
109 (efs-save-match-data
|
|
|
110 (if reverse
|
|
|
111 (if (string-match
|
|
|
112 "^\\([^:]+:\\)?\\(\\[[^]]+\\]\\)?\\([^][]*\\)$" path)
|
|
|
113 (let (drive dir file)
|
|
|
114 (if (match-beginning 1)
|
|
|
115 (setq drive (substring path
|
|
|
116 (match-beginning 1)
|
|
|
117 (match-end 1))))
|
|
|
118 (if (match-beginning 2)
|
|
|
119 (setq dir
|
|
|
120 (substring path (match-beginning 2) (match-end 2))))
|
|
|
121 (if (match-beginning 3)
|
|
|
122 (setq file
|
|
|
123 (substring path (match-beginning 3) (match-end 3))))
|
|
|
124 (and dir
|
|
|
125 (setq dir (apply (function concat)
|
|
|
126 (mapcar (function
|
|
|
127 (lambda (char)
|
|
|
128 (if (= char ?.)
|
|
|
129 (vector ?/)
|
|
|
130 (vector char))))
|
|
|
131 (substring dir 1 -1)))))
|
|
|
132 (concat (and drive
|
|
|
133 (concat "/" drive "/"))
|
|
|
134 dir (and dir "/")
|
|
|
135 file))
|
|
|
136 (error "path %s didn't match" path))
|
|
|
137 (let (drive dir file)
|
|
|
138 (if (string-match "^/[^:/]+:/" path)
|
|
|
139 (setq drive (substring path 1 (1- (match-end 0)))
|
|
|
140 path (substring path (1- (match-end 0)))))
|
|
|
141 (setq dir (file-name-directory path)
|
|
|
142 file (efs-internal-file-name-nondirectory path))
|
|
|
143 (if dir
|
|
|
144 (let ((len (1- (length dir)))
|
|
|
145 (n 0))
|
|
|
146 (if (<= len 0)
|
|
|
147 (setq dir nil)
|
|
|
148 (while (<= n len)
|
|
|
149 (and (char-equal (aref dir n) ?/)
|
|
|
150 (cond
|
|
|
151 ((zerop n) (aset dir n ?\[))
|
|
|
152 ((= n len) (aset dir n ?\]))
|
|
|
153 (t (aset dir n ?.))))
|
|
|
154 (setq n (1+ n))))))
|
|
|
155 (concat drive dir file)))))
|
|
|
156
|
|
|
157 ;; It is important that this function barf for directories for which we know
|
|
|
158 ;; that we cannot possibly get a directory listing, such as "/" and "/DEV:/".
|
|
|
159 ;; This is because it saves an unnecessary FTP error, or possibly the listing
|
|
|
160 ;; might succeed, but give erroneous info. This last case is particularly
|
|
|
161 ;; likely for OS's (like MTS) for which we need to use a wildcard in order
|
|
|
162 ;; to list a directory.
|
|
|
163
|
|
|
164 (efs-defun efs-fix-dir-path vms (dir-path)
|
|
|
165 ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing.
|
|
|
166 ;; Should there be entries for .. -> [-] and . -> [] below. Don't
|
|
|
167 ;; think so, because expand-filename should have already short-circuited
|
|
|
168 ;; them.
|
|
|
169 (cond ((string-equal dir-path "/")
|
|
|
170 (error "Cannot get listing for fictitious \"/\" directory."))
|
|
|
171 ((string-match "^/[-A-Z0-9_$]+:/$" dir-path)
|
|
|
172 (error "Cannot get listing for device."))
|
|
|
173 ((efs-fix-path 'vms dir-path))))
|
|
|
174
|
|
|
175 ;; These parsing functions are as general as possible because the syntax
|
|
|
176 ;; of ftp listings from VMS hosts is a bit erratic. What saves us is that
|
|
|
177 ;; the VMS filename syntax is so rigid. If they bomb on a listing in the
|
|
|
178 ;; standard VMS Multinet format, then this is a bug. If they bomb on a listing
|
|
|
179 ;; from vms.weird.net, then too bad.
|
|
|
180
|
|
|
181 (defmacro efs-parse-vms-filename ()
|
|
|
182 "Extract the next filename from a VMS dired-like listing."
|
|
|
183 (` (if (re-search-forward
|
|
|
184 efs-vms-filename-regexp
|
|
|
185 nil t)
|
|
|
186 (buffer-substring (match-beginning 0) (match-end 0)))))
|
|
|
187
|
|
|
188 (defun efs-parse-vms-listing ()
|
|
|
189 ;; Parse the current buffer which is assumed to be a VMS DIR
|
|
|
190 ;; listing (either a short (NLIST) or long listing).
|
|
|
191 ;; Assumes that point is at the beginning of the buffer.
|
|
|
192 (let ((tbl (efs-make-hashtable))
|
|
|
193 file)
|
|
|
194 (goto-char (point-min))
|
|
|
195 (efs-save-match-data
|
|
|
196 (while (setq file (efs-parse-vms-filename))
|
|
|
197 (if (string-match "\\.\\(DIR\\|dir\\);[0-9]+" file)
|
|
|
198 ;; deal with directories
|
|
|
199 (efs-put-hash-entry
|
|
|
200 (substring file 0 (match-beginning 0)) '(t) tbl)
|
|
|
201 (efs-put-hash-entry file '(nil) tbl)
|
|
|
202 (if (string-match ";[0-9]+$" file) ; deal with extension
|
|
|
203 ;; sans extension
|
|
|
204 (efs-put-hash-entry
|
|
|
205 (substring file 0 (match-beginning 0)) '(nil) tbl)))
|
|
|
206 (forward-line 1))
|
|
|
207 ;; Would like to look for a "Total" line, or a "Directory" line to
|
|
|
208 ;; make sure that the listing isn't complete garbage before putting
|
|
|
209 ;; in "." and "..", but we can't even count on all VAX's giving us
|
|
|
210 ;; either of these.
|
|
|
211 (efs-put-hash-entry "." '(t) tbl)
|
|
|
212 (efs-put-hash-entry ".." '(t) tbl))
|
|
|
213 tbl))
|
|
|
214
|
|
|
215 (efs-defun efs-parse-listing vms
|
|
|
216 (host user dir path &optional switches)
|
|
|
217 ;; Parse the current buffer which is assumed to be a VMS FTP dir
|
|
|
218 ;; format, and return a hashtable as the result. SWITCHES are never used,
|
|
|
219 ;; but they must be specified in the argument list for compatibility
|
|
|
220 ;; with the unix version of this function.
|
|
|
221 ;; HOST = remote host name
|
|
|
222 ;; USER = user name
|
|
|
223 ;; DIR = directory in as a full remote path
|
|
|
224 ;; PATH = directory in full efs path syntax
|
|
|
225 ;; SWITCHES = ls switches (not relevant here)
|
|
|
226 (goto-char (point-min))
|
|
|
227 (efs-save-match-data
|
|
|
228 ;; check for a DIR/FULL monstrosity
|
|
|
229 (if (search-forward "\nSize:" nil t)
|
|
|
230 (progn
|
|
|
231 (efs-add-listing-type 'vms:full host user)
|
|
|
232 ;; This will cause the buffer to be refilled with an NLIST
|
|
|
233 (let ((efs-ls-uncache t))
|
|
|
234 (efs-ls path nil (format "Relisting %s"
|
|
|
235 (efs-relativize-filename path))
|
|
|
236 t))
|
|
|
237 (goto-char (point-min))
|
|
|
238 (efs-parse-vms-listing))
|
|
|
239 (efs-parse-vms-listing))))
|
|
|
240
|
|
|
241
|
|
|
242 ;;;; Sorting of listings
|
|
|
243
|
|
|
244 (efs-defun efs-t-converter vms (&optional regexp reverse)
|
|
|
245 (if regexp
|
|
|
246 nil
|
|
|
247 (goto-char (point-min))
|
|
|
248 (efs-save-match-data
|
|
|
249 (if (re-search-forward efs-vms-filename-regexp nil t)
|
|
|
250 (let (list-start start end list)
|
|
|
251 (beginning-of-line)
|
|
|
252 (setq list-start (point))
|
|
|
253 (while (and (looking-at efs-vms-filename-regexp)
|
|
|
254 (progn
|
|
|
255 (setq start (point))
|
|
|
256 (goto-char (match-end 0))
|
|
|
257 (forward-line (if (eolp) 2 1))
|
|
|
258 (setq end (point))
|
|
|
259 (goto-char (match-end 0))
|
|
|
260 (re-search-forward efs-vms-date-regexp nil t)))
|
|
|
261 (setq list
|
|
|
262 (cons
|
|
|
263 (cons
|
|
|
264 (nconc
|
|
|
265 (list (string-to-int (buffer-substring
|
|
|
266 (match-beginning 3)
|
|
|
267 (match-end 3))) ; year
|
|
|
268 (cdr (assoc
|
|
|
269 (buffer-substring (match-beginning 2)
|
|
|
270 (match-end 2))
|
|
|
271 efs-vms-month-alist)) ; month
|
|
|
272 (string-to-int (buffer-substring
|
|
|
273 (match-beginning 1)
|
|
|
274 (match-end 1)))) ;day
|
|
|
275 (if (match-beginning 4)
|
|
|
276 (list
|
|
|
277 (string-to-int (buffer-substring
|
|
|
278 (match-beginning 5)
|
|
|
279 (match-end 5))) ; hour
|
|
|
280 (string-to-int (buffer-substring
|
|
|
281 (match-beginning 6)
|
|
|
282 (match-end 6))) ; minute
|
|
|
283 (if (match-beginning 7)
|
|
|
284 (string-to-int (buffer-substring
|
|
|
285 (1+ (match-beginning 7))
|
|
|
286 (match-end 7))) ; seconds
|
|
|
287 0))
|
|
|
288 (list 0 0 0)))
|
|
|
289 (buffer-substring start end))
|
|
|
290 list))
|
|
|
291 (goto-char end))
|
|
|
292 (if list
|
|
|
293 (progn
|
|
|
294 (setq list
|
|
|
295 (mapcar 'cdr
|
|
|
296 (sort list 'efs-vms-t-converter-sort-pred)))
|
|
|
297 (if reverse (setq list (nreverse list)))
|
|
|
298 (delete-region list-start (point))
|
|
|
299 (apply 'insert list)))
|
|
|
300 t)))))
|
|
|
301
|
|
|
302 (defun efs-vms-t-converter-sort-pred (elt1 elt2)
|
|
|
303 (let* ((data1 (car elt1))
|
|
|
304 (data2 (car elt2))
|
|
|
305 (year1 (car data1))
|
|
|
306 (year2 (car data2))
|
|
|
307 (month1 (nth 1 data1))
|
|
|
308 (month2 (nth 1 data2))
|
|
|
309 (day1 (nth 2 data1))
|
|
|
310 (day2 (nth 2 data2))
|
|
|
311 (hour1 (nth 3 data1))
|
|
|
312 (hour2 (nth 3 data2))
|
|
|
313 (minute1 (nth 4 data1))
|
|
|
314 (minute2 (nth 4 data2)))
|
|
|
315 (or (> year1 year2)
|
|
|
316 (and (= year1 year2)
|
|
|
317 (or (> month1 month2)
|
|
|
318 (and (= month1 month2)
|
|
|
319 (or (> day1 day2)
|
|
|
320 (and (= day1 day2)
|
|
|
321 (or (> hour1 hour2)
|
|
|
322 (and (= hour1 hour2)
|
|
|
323 (or (> minute1 minute2)
|
|
|
324 (and (= minute1 minute2)
|
|
|
325 (or (> (nth 5 data1)
|
|
|
326 (nth 5 data2)))
|
|
|
327 ))))))))))))
|
|
|
328
|
|
|
329
|
|
|
330 (efs-defun efs-X-converter vms (&optional regexp reverse)
|
|
|
331 ;; Sorts by extension
|
|
|
332 (if regexp
|
|
|
333 nil
|
|
|
334 (goto-char (point-min))
|
|
|
335 (efs-save-match-data
|
|
|
336 (if (re-search-forward efs-vms-filename-regexp nil t)
|
|
|
337 (let (list-start start list)
|
|
|
338 (beginning-of-line)
|
|
|
339 (setq list-start (point))
|
|
|
340 (while (looking-at efs-vms-filename-regexp)
|
|
|
341 (setq start (point))
|
|
|
342 (goto-char (match-end 0))
|
|
|
343 (forward-line (if (eolp) 2 1))
|
|
|
344 (setq list
|
|
|
345 (cons
|
|
|
346 (cons (buffer-substring (match-beginning 2)
|
|
|
347 (match-end 2))
|
|
|
348 (buffer-substring start (point)))
|
|
|
349 list)))
|
|
|
350 (setq list
|
|
|
351 (mapcar 'cdr
|
|
|
352 (sort list
|
|
|
353 (if reverse
|
|
|
354 (function
|
|
|
355 (lambda (x y)
|
|
|
356 (string< (car y) (car x))))
|
|
|
357 (function
|
|
|
358 (lambda (x y)
|
|
|
359 (string< (car x) (car y))))))))
|
|
|
360 (delete-region list-start (point))
|
|
|
361 (apply 'insert list)
|
|
|
362 t)))))
|
|
|
363
|
|
|
364 ;; This version only deletes file entries which have
|
|
|
365 ;; explicit version numbers, because that is all VMS allows.
|
|
|
366
|
|
|
367 (efs-defun efs-delete-file-entry vms (path &optional dir-p)
|
|
|
368 (let ((ignore-case (memq 'vms efs-case-insensitive-host-types)))
|
|
|
369 (if dir-p
|
|
|
370 (let ((path (file-name-as-directory path))
|
|
|
371 files)
|
|
|
372 (efs-del-hash-entry path efs-files-hashtable ignore-case)
|
|
|
373 (setq path (directory-file-name path)
|
|
|
374 files (efs-get-hash-entry (file-name-directory path)
|
|
|
375 efs-files-hashtable
|
|
|
376 ignore-case))
|
|
|
377 (if files
|
|
|
378 (efs-del-hash-entry (efs-get-file-part path)
|
|
|
379 files ignore-case)))
|
|
|
380 (efs-save-match-data
|
|
|
381 (let ((file (efs-get-file-part path)))
|
|
|
382 (if (string-match ";[0-9]+$" file)
|
|
|
383 ;; In VMS you can't delete a file without an explicit
|
|
|
384 ;; version number, or wild-card (e.g. FOO;*)
|
|
|
385 ;; For now, we give up on wildcards.
|
|
|
386 (let ((files (efs-get-hash-entry
|
|
|
387 (file-name-directory path)
|
|
|
388 efs-files-hashtable ignore-case)))
|
|
|
389 (if files
|
|
|
390 (let ((root (substring file 0
|
|
|
391 (match-beginning 0)))
|
|
|
392 (completion-ignore-case ignore-case)
|
|
|
393 (len (match-beginning 0)))
|
|
|
394 (efs-del-hash-entry file files ignore-case)
|
|
|
395 ;; Now we need to check if there are any
|
|
|
396 ;; versions left. If not, then delete the
|
|
|
397 ;; root entry.
|
|
|
398 (or (all-completions
|
|
|
399 root files
|
|
|
400 (function
|
|
|
401 (lambda (sym)
|
|
|
402 (string-match ";[0-9]+$"
|
|
|
403 (symbol-name sym) len))))
|
|
|
404 (efs-del-hash-entry root files
|
|
|
405 ignore-case)))))))))
|
|
|
406 (efs-del-from-ls-cache path t ignore-case)))
|
|
|
407
|
|
|
408 (efs-defun efs-add-file-entry vms (path dir-p size owner
|
|
|
409 &optional modes nlinks mdtm)
|
|
|
410 ;; The vms version of this function needs to keep track
|
|
|
411 ;; of vms's file versions.
|
|
|
412 (let ((ignore-case (memq 'vms efs-case-insensitive-host-types))
|
|
|
413 (ent (let ((dir-p (null (null dir-p))))
|
|
|
414 (if mdtm
|
|
|
415 (list dir-p size owner nil nil mdtm)
|
|
|
416 (list dir-p size owner)))))
|
|
|
417 (if dir-p
|
|
|
418 (let* ((path (directory-file-name path))
|
|
|
419 (files (efs-get-hash-entry (file-name-directory path)
|
|
|
420 efs-files-hashtable
|
|
|
421 ignore-case)))
|
|
|
422 (if files
|
|
|
423 (efs-put-hash-entry (efs-get-file-part path)
|
|
|
424 ent files ignore-case)))
|
|
|
425 (let ((files (efs-get-hash-entry
|
|
|
426 (file-name-directory path)
|
|
|
427 efs-files-hashtable ignore-case)))
|
|
|
428 (if files
|
|
|
429 (let ((file (efs-get-file-part path)))
|
|
|
430 (efs-save-match-data
|
|
|
431 ;; In VMS files must have an extension. If there isn't
|
|
|
432 ;; one, it will be added.
|
|
|
433 (or (string-match "^[^;]*\\." file)
|
|
|
434 (if (string-match ";" file)
|
|
|
435 (setq file (concat
|
|
|
436 (substring file 0 (match-beginning 0))
|
|
|
437 ".;"
|
|
|
438 (substring file (match-end 0))))
|
|
|
439 (setq file (concat file "."))))
|
|
|
440 (if (string-match ";[0-9]+$" file)
|
|
|
441 (efs-put-hash-entry
|
|
|
442 (substring file 0 (match-beginning 0))
|
|
|
443 ent files ignore-case)
|
|
|
444 ;; Need to figure out what version of the file
|
|
|
445 ;; is being added.
|
|
|
446 (let* ((completion-ignore-case ignore-case)
|
|
|
447 (len (length file))
|
|
|
448 (versions (all-completions
|
|
|
449 file files
|
|
|
450 (function
|
|
|
451 (lambda (sym)
|
|
|
452 (string-match ";[0-9]+$"
|
|
|
453 (symbol-name sym) len)))))
|
|
|
454 (N (1+ len))
|
|
|
455 (max (apply
|
|
|
456 'max
|
|
|
457 (cons 0 (mapcar
|
|
|
458 (function
|
|
|
459 (lambda (x)
|
|
|
460 (string-to-int (substring x N))))
|
|
|
461 versions)))))
|
|
|
462 ;; No need to worry about case here.
|
|
|
463 (efs-put-hash-entry
|
|
|
464 (concat file ";" (int-to-string (1+ max))) ent files))))
|
|
|
465 (efs-put-hash-entry file ent files ignore-case)))))
|
|
|
466 (efs-del-from-ls-cache path t ignore-case)))
|
|
|
467
|
|
|
468 (efs-defun efs-really-file-p vms (file ent)
|
|
|
469 ;; Returns whether the hash entry FILE with entry ENT is a real file.
|
|
|
470 (or (car ent) ; file-directory-p
|
|
|
471 (efs-save-match-data
|
|
|
472 (string-match ";" file))))
|
|
|
473
|
|
|
474 (efs-defun efs-internal-file-name-as-directory vms (name)
|
|
|
475 (efs-save-match-data
|
|
|
476 (if (string-match "\\.\\(DIR\\|dir\\)\\(;[0-9]+\\)?$" name)
|
|
|
477 (setq name (substring name 0 (match-beginning 0))))
|
|
|
478 (let (file-name-handler-alist)
|
|
|
479 (file-name-as-directory name))))
|
|
|
480
|
|
|
481 (efs-defun efs-remote-directory-file-name vms (dir)
|
|
|
482 ;; Returns the VMS filename in unix directory syntax for directory DIR.
|
|
|
483 ;; This is something like /FM/SANDY/FOOBAR.DIR;1
|
|
|
484 (efs-save-match-data
|
|
|
485 (setq dir (directory-file-name dir))
|
|
|
486 (concat dir
|
|
|
487 (if (string-match "[a-z]" (nth 2 (efs-ftp-path dir)))
|
|
|
488 ".dir;1"
|
|
|
489 ".DIR;1"))))
|
|
|
490
|
|
|
491 (efs-defun efs-allow-child-lookup vms (host user dir file)
|
|
|
492 ;; Returns t if FILE in directory DIR could possibly be a subdir
|
|
|
493 ;; according to its file-name syntax, and therefore a child listing should
|
|
|
494 ;; be attempted.
|
|
|
495
|
|
|
496 ;; Subdirs in VMS can't have an extension (other than .DIR, which we
|
|
|
497 ;; have truncated).
|
|
|
498 (not (or (string-match "\\." file)
|
|
|
499 (and (boundp 'dired-local-variables-file)
|
|
|
500 (stringp dired-local-variables-file)
|
|
|
501 (string-equal dired-local-variables-file file)))))
|
|
|
502
|
|
|
503 ;;; Tree dired support:
|
|
|
504
|
|
|
505 ;; For this code I have borrowed liberally from Sebastian Kremer's
|
|
|
506 ;; dired-vms.el
|
|
|
507
|
|
|
508
|
|
|
509 ;; These regexps must be anchored to beginning of line.
|
|
|
510 ;; Beware that the ftpd may put the device in front of the filename.
|
|
|
511
|
|
|
512 (defconst efs-dired-vms-re-exe
|
|
|
513 "^. [^ \t.]+\\.\\(EXE\\|exe\\)[; ]")
|
|
|
514
|
|
|
515 (or (assq 'vms efs-dired-re-exe-alist)
|
|
|
516 (setq efs-dired-re-exe-alist
|
|
|
517 (cons (cons 'vms efs-dired-vms-re-exe)
|
|
|
518 efs-dired-re-exe-alist)))
|
|
|
519
|
|
|
520 (defconst efs-dired-vms-re-dir
|
|
|
521 "^. [^ \t.]+\\.\\(DIR\\|dir\\)[; ]")
|
|
|
522
|
|
|
523 (or (assq 'vms efs-dired-re-dir-alist)
|
|
|
524 (setq efs-dired-re-dir-alist
|
|
|
525 (cons (cons 'vms efs-dired-vms-re-dir)
|
|
|
526 efs-dired-re-dir-alist)))
|
|
|
527
|
|
|
528 (efs-defun efs-dired-insert-headerline vms (dir)
|
|
|
529 ;; VMS inserts a headerline. I would prefer the headerline
|
|
|
530 ;; to be in efs format. This version tries to
|
|
|
531 ;; be careful, because we can't count on a headerline
|
|
|
532 ;; over ftp, and we wouldn't want to delete anything
|
|
|
533 ;; important.
|
|
|
534 (save-excursion
|
|
|
535 (if (looking-at "^ \\(list \\)?wildcard ")
|
|
|
536 (forward-line 1))
|
|
|
537 ;; This is really aggressive. Too aggressive?
|
|
|
538 (let ((start (point)))
|
|
|
539 (skip-chars-forward " \t\n")
|
|
|
540 (if (looking-at efs-vms-filename-regexp)
|
|
|
541 (beginning-of-line)
|
|
|
542 (forward-line 1)
|
|
|
543 (skip-chars-forward " \t\n")
|
|
|
544 (beginning-of-line))
|
|
|
545 (delete-region start (point)))
|
|
|
546 (insert " \n"))
|
|
|
547 (efs-real-dired-insert-headerline dir))
|
|
|
548
|
|
|
549 (efs-defun efs-dired-fixup-listing vms (file path &optional switches wildcard)
|
|
|
550 ;; Some vms machines list the entire path. Scrape this off.
|
|
|
551 (setq path (efs-fix-path
|
|
|
552 'vms
|
|
|
553 ;; Need the file-name-directory, in case of widcards.
|
|
|
554 ;; Note that path is a `local' path rel. the remote host.
|
|
|
555 ;; Lose on wildcards in parent dirs. Fix if somebody complains.
|
|
|
556 (let (file-name-handler-alist)
|
|
|
557 (file-name-directory path))))
|
|
|
558 ;; Some machines put a Node name down too.
|
|
|
559 (let ((regexp (concat "^\\([_A-Za-z0-9][-_A-Za-z0-9]*\\$\\)?"
|
|
|
560 (regexp-quote path))))
|
|
|
561 (goto-char (point-min))
|
|
|
562 (while (re-search-forward regexp nil t)
|
|
|
563 (delete-region (match-beginning 0) (match-end 0))))
|
|
|
564 ;; Now need to deal with continuation lines.
|
|
|
565 (goto-char (point-min))
|
|
|
566 (let (col start end)
|
|
|
567 (while (re-search-forward
|
|
|
568 ";[0-9]+[ \t]*\\(\n[ \t]+\\)[^; \t\n]+[^\n;]*\n" nil t)
|
|
|
569 (setq start (match-beginning 1)
|
|
|
570 end (match-end 1))
|
|
|
571 ;; guess at the column dimensions
|
|
|
572 (or col
|
|
|
573 (save-excursion
|
|
|
574 (goto-char (point-min))
|
|
|
575 (if (re-search-forward
|
|
|
576 (concat efs-vms-filename-regexp
|
|
|
577 "[ \t]+[^ \t\n\r]") nil t)
|
|
|
578 (setq col (- (goto-char (match-end 0))
|
|
|
579 (progn (beginning-of-line) (point))
|
|
|
580 1))
|
|
|
581 (setq col 0))))
|
|
|
582 ;; join cont. lines.
|
|
|
583 (delete-region start end)
|
|
|
584 (goto-char start)
|
|
|
585 (insert-char ? (max (- col (current-column)) 2))))
|
|
|
586 ;; Some vms dir listings put a triple null line before the total line.
|
|
|
587 (goto-char (point-min))
|
|
|
588 (skip-chars-forward "\n")
|
|
|
589 (if (search-forward "\n\n\n" nil t)
|
|
|
590 (delete-char -1)))
|
|
|
591
|
|
|
592 (efs-defun efs-dired-manual-move-to-filename vms
|
|
|
593 (&optional raise-error bol eol)
|
|
|
594 ;; In dired, move to first char of filename on this line.
|
|
|
595 ;; Returns position (point) or nil if no filename on this line.
|
|
|
596 ;; This is the VMS version.
|
|
|
597 (or eol (setq eol (save-excursion (skip-chars-forward "^\r\n") (point))))
|
|
|
598 (let (case-fold-search)
|
|
|
599 (if bol
|
|
|
600 (goto-char bol)
|
|
|
601 (skip-chars-backward "^\n\r"))
|
|
|
602 (if (re-search-forward efs-vms-filename-regexp eol t)
|
|
|
603 (goto-char (match-beginning 0))
|
|
|
604 (and raise-error (error "No file on this line")))))
|
|
|
605
|
|
|
606 (efs-defun efs-dired-manual-move-to-end-of-filename vms
|
|
|
607 (&optional no-error bol eol)
|
|
|
608 ;; Assumes point is at beginning of filename.
|
|
|
609 ;; So, it should be called only after (dired-move-to-filename t).
|
|
|
610 ;; case-fold-search must be nil, at least for VMS.
|
|
|
611 ;; On failure, signals an error or returns nil.
|
|
|
612 ;; This is the VMS version.
|
|
|
613 (let ((opoint (point)))
|
|
|
614 (and selective-display
|
|
|
615 (null no-error)
|
|
|
616 (eq (char-after
|
|
|
617 (1- (or bol (save-excursion
|
|
|
618 (skip-chars-backward "^\r\n")
|
|
|
619 (point)))))
|
|
|
620 ?\r)
|
|
|
621 ;; File is hidden or omitted.
|
|
|
622 (cond
|
|
|
623 ((dired-subdir-hidden-p (dired-current-directory))
|
|
|
624 (error
|
|
|
625 (substitute-command-keys
|
|
|
626 "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
|
|
|
627 ((error
|
|
|
628 (substitute-command-keys
|
|
|
629 "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
|
|
|
630 )))))
|
|
|
631 (skip-chars-forward "-_A-Za-z0-9$.;")
|
|
|
632 (if (or (= opoint (point)) (not (memq (following-char) '(?\ ?\t ?\n ?\r))))
|
|
|
633 (if no-error
|
|
|
634 nil
|
|
|
635 (error "No file on this line"))
|
|
|
636 (point))))
|
|
|
637
|
|
|
638 (efs-defun efs-dired-ls-trim vms ()
|
|
|
639 (goto-char (point-min))
|
|
|
640 (let ((case-fold-search nil))
|
|
|
641 (re-search-forward efs-vms-filename-regexp))
|
|
|
642 (beginning-of-line)
|
|
|
643 (delete-region (point-min) (point))
|
|
|
644 (forward-line 1)
|
|
|
645 (delete-region (point) (point-max)))
|
|
|
646
|
|
|
647 (efs-defun efs-internal-file-name-sans-versions vms
|
|
|
648 (name &optional keep-backup-version)
|
|
|
649 (efs-save-match-data
|
|
|
650 (if (string-match ";[0-9]+$" name)
|
|
|
651 (substring name 0 (match-beginning 0))
|
|
|
652 name)))
|
|
|
653
|
|
|
654 (efs-defun efs-dired-collect-file-versions vms ()
|
|
|
655 ;; If it looks like file FN has versions, return a list of the versions.
|
|
|
656 ;; That is a list of strings which are file names.
|
|
|
657 ;; The caller may want to flag some of these files for deletion.
|
|
|
658 (let ((completion-ignore-case (memq 'vms efs-case-insensitive-host-types))
|
|
|
659 result)
|
|
|
660 (dired-map-dired-file-lines
|
|
|
661 (function
|
|
|
662 (lambda (fn)
|
|
|
663 (if (string-match ";[0-9]+$" fn)
|
|
|
664 (let* ((base-fn (substring fn 0 (match-beginning 0)))
|
|
|
665 (base-version (file-name-nondirectory
|
|
|
666 (substring fn 0 (1+ (match-beginning 0)))))
|
|
|
667 (bv-length (length base-version))
|
|
|
668 (possibilities (and
|
|
|
669 (null (assoc base-fn result))
|
|
|
670 (file-name-all-completions
|
|
|
671 base-version
|
|
|
672 (file-name-directory fn)))))
|
|
|
673 (if possibilities
|
|
|
674 (setq result
|
|
|
675 (cons (cons base-fn
|
|
|
676 ;; code this explicitly
|
|
|
677 ;; using backup-extract-version has a
|
|
|
678 ;; lot of function-call overhead.
|
|
|
679 (mapcar (function
|
|
|
680 (lambda (fn)
|
|
|
681 (string-to-int
|
|
|
682 (substring fn bv-length))))
|
|
|
683 possibilities)) result))))))))
|
|
|
684 result))
|
|
|
685
|
|
|
686 (efs-defun efs-dired-flag-backup-files vms (&optional unflag-p)
|
|
|
687 (interactive "P")
|
|
|
688 (let ((dired-kept-versions 1)
|
|
|
689 (kept-old-versions 0)
|
|
|
690 marker msg)
|
|
|
691 (if unflag-p
|
|
|
692 (setq marker ?\040 msg "Unflagging old versions")
|
|
|
693 (setq marker dired-del-marker msg "Purging old versions"))
|
|
|
694 (dired-clean-directory 1 marker msg)))
|
|
|
695
|
|
|
696 (efs-defun efs-internal-diff-latest-backup-file vms (fn)
|
|
|
697 ;; For FILE;#, returns the filename FILE;N, where N
|
|
|
698 ;; is the largest number less than #, for which this file exists.
|
|
|
699 ;; Returns nil if none found.
|
|
|
700 (efs-save-match-data
|
|
|
701 (and (string-match ";[0-9]+$" fn)
|
|
|
702 (let ((base (substring fn 0 (1+ (match-beginning 0))))
|
|
|
703 (num (1- (string-to-int (substring fn
|
|
|
704 (1+ (match-beginning 0))))))
|
|
|
705 found file)
|
|
|
706 (while (and (setq found (> num 0))
|
|
|
707 (not (file-exists-p
|
|
|
708 (setq file
|
|
|
709 (concat base (int-to-string num))))))
|
|
|
710 (setq num (1- num)))
|
|
|
711 (and found file)))))
|
|
|
712
|
|
|
713 ;;;;--------------------------------------------------------------
|
|
|
714 ;;;; Support for VMS DIR/FULL listings. (listing type vms:full)
|
|
|
715 ;;;;--------------------------------------------------------------
|
|
|
716
|
|
|
717 (efs-defun efs-parse-listing vms:full
|
|
|
718 (host user dir path &optional switches)
|
|
|
719 ;; Parse the current buffer which is assumed to be a VMS FTP dir
|
|
|
720 ;; format, and return a hashtable as the result. SWITCHES are never used,
|
|
|
721 ;; but they must be specified in the argument list for compatibility
|
|
|
722 ;; with the unix version of this function.
|
|
|
723 ;; HOST = remote host name
|
|
|
724 ;; USER = user name
|
|
|
725 ;; DIR = directory in as a full remote path
|
|
|
726 ;; PATH = directory in full efs path syntax
|
|
|
727 ;; SWITCHES = ls switches (not relevant here)
|
|
|
728 (goto-char (point-min))
|
|
|
729 (efs-save-match-data
|
|
|
730 (efs-parse-vms-listing)))
|
|
|
731
|
|
|
732 ;;; Tree Dired
|
|
|
733
|
|
|
734 (or (assq 'vms:full efs-dired-re-exe-alist)
|
|
|
735 (setq efs-dired-re-exe-alist
|
|
|
736 (cons (cons 'vms:full efs-dired-vms-re-exe)
|
|
|
737 efs-dired-re-exe-alist)))
|
|
|
738
|
|
|
739 (or (assq 'vms:full efs-dired-re-dir-alist)
|
|
|
740 (setq efs-dired-re-dir-alist
|
|
|
741 (cons (cons 'vms:full efs-dired-vms-re-dir)
|
|
|
742 efs-dired-re-dir-alist)))
|
|
|
743
|
|
|
744 (efs-defun efs-dired-insert-headerline vms:full (dir)
|
|
|
745 ;; Insert a blank line for aesthetics.
|
|
|
746 (insert " \n")
|
|
|
747 (forward-char -2)
|
|
|
748 (efs-real-dired-insert-headerline dir))
|
|
|
749
|
|
|
750 (efs-defun efs-dired-manual-move-to-filename vms:full
|
|
|
751 (&optional raise-error bol eol)
|
|
|
752 (let ((efs-dired-listing-type 'vms))
|
|
|
753 (efs-dired-manual-move-to-filename raise-error bol eol)))
|
|
|
754
|
|
|
755 (efs-defun efs-dired-manual-move-to-end-of-filename vms:full
|
|
|
756 (&optional no-error bol eol)
|
|
|
757 (let ((efs-dired-listing-type 'vms))
|
|
|
758 (efs-dired-manual-move-to-end-of-filename no-error bol eol)))
|
|
|
759
|
|
|
760 ;;; end of efs-vms.el
|
