Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-vms.el @ 22:8fc7fe29b841 r19-15b94

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Import from CVS: tag r19-15b94
author cvs
date Mon, 13 Aug 2007 08:50:29 +0200
parents
children 7e54bd776075 9f59509498e1
comparison
equal deleted inserted replaced
21:b88636d63495 22:8fc7fe29b841
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-vms.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.1 $
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 "/"
23 (substring "$Revision: 1.1 $" 11 -2)))
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