Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-tops-20.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 8b8b7f3559a2 8619ce7e4c50
comparison
equal deleted inserted replaced
21:b88636d63495 22:8fc7fe29b841
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-tops-20.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.1 $
7 ;; RCS:
8 ;; Description: TOPS-20 support for efs
9 ;; Author: Sandy Rutherford <sandy@math.ubc.ca, sandy@itp.ethz.ch>
10 ;; Created: Fri Oct 23 08:52:00 1992
11 ;; Modified: Sun Nov 27 18:43:45 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 (require 'efs)
20 (provide 'efs-tops-20)
21
22 (defconst efs-tops-20-version
23 (concat (substring "$efs release: 1.15 $" 14 -2)
24 "/"
25 (substring "$Revision: 1.1 $" 11 -2)))
26
27 ;;;; ------------------------------------------------------------
28 ;;;; TOPS-20 support
29 ;;;; ------------------------------------------------------------
30
31 (efs-defun efs-send-pwd tops-20 (host user &optional xpwd)
32 ;; pwd doesn't work for tops-20. Need to get the cwd from a dir listing
33 ;; this function returns the cwd in tops-20 syntax
34 (let* ((temp (efs-make-tmp-name host nil))
35 (cmd (concat "dir * " (cdr temp)))
36 dir u-dir full-dir result)
37 (unwind-protect
38 (if (null (and (car (setq result (efs-raw-send-cmd
39 (efs-get-process host user)
40 cmd
41 "Getting TOPS-20 PWD")))
42 (progn
43 (condition-case ()
44 (delete-file (car temp)) (error nil))
45 (car (setq result
46 (efs-raw-send-cmd
47 (efs-get-process host user)
48 cmd
49 "Trying to get TOPS-20 PWD, again."))))))
50 (save-excursion
51 (set-buffer (get-buffer-create
52 efs-data-buffer-name))
53 (erase-buffer)
54 (if (or (file-readable-p (car temp))
55 (sleep-for efs-retry-time)
56 (file-readable-p (car temp)))
57 ;; Try again.
58 (insert-file-contents (car temp))
59 (efs-error host user
60 (format
61 "list data file %s not readable" (car temp))))
62 ;; get the cwd
63 (goto-char (point-min))
64 (efs-save-match-data
65 (if (looking-at "[^ /:]+:<[^<>/ ]+>")
66 (progn
67 (setq dir (buffer-substring (match-beginning 0)
68 (match-end 0))
69 u-dir (efs-internal-directory-file-name
70 (efs-fix-path 'tops-20 dir t))
71 full-dir (format efs-path-format-string
72 user host u-dir))
73 ;; cache the files too
74 (efs-set-files full-dir
75 (efs-parse-listing
76 'tops-20 host user u-dir full-dir))
77 (efs-add-to-ls-cache full-dir nil (buffer-string) t))))))
78 (efs-del-tmp-name (car temp)))
79 (cons dir (nth 1 result))))
80
81 (efs-defun efs-fix-path tops-20 (path &optional reverse)
82 ;; Convert PATH from UNIX-ish to tops-20. If REVERSE given, then
83 ;; do just that.
84 (efs-save-match-data
85 (if reverse
86 (if (string-match "^\\([^:]+:\\)?<\\([^>.][^>]*\\)>.*$" path)
87 (let ((device (and (match-beginning 1)
88 (substring path (match-beginning 1)
89 (match-end 1))))
90 (dir (substring path (match-beginning 2)
91 (match-end 2)))
92 (file (substring path (1+ (match-end 2)))))
93 (while (string-match "\\." dir)
94 (setq dir (concat (substring dir 0 (match-beginning 0))
95 "/"
96 (substring dir (match-end 0)))))
97 (if device
98 (setq dir (concat "/" device "/" dir)))
99 (concat dir file))
100 (error "path %s didn't match tops-20 syntax" path))
101 (if (string-match "^\\(/[^:/]+:/\\)?\\([^./]+/\\)*\\([^/]*\\)$" path)
102 (let ((device (and (match-beginning 1)
103 (substring path 1 (1- (match-end 1)))))
104 (dir (and (match-beginning 2)
105 (substring path (match-beginning 2)
106 (1- (match-end 2)))))
107 (file (substring path (match-beginning 3)
108 (match-end 3))))
109 (if dir
110 (progn
111 (while (string-match "/" dir)
112 (setq dir (concat (substring dir 0 (match-beginning 0))
113 "."
114 (substring dir (match-end 0)))))
115 (if device
116 (concat device "<" dir ">" file)
117 (concat "<" dir ">" file)))
118 (if device
119 (error "%s is invalid relative syntax for tops-20" path)
120 file)))
121 (error "path %s is invalid syntax for tops-20" path)))))
122
123 (efs-defun efs-fix-dir-path tops-20 (dir-path)
124 ;; Convert a path from UNIX-ish to Tops-20 fir a dir listing.
125 (cond ((string-equal "/" dir-path)
126 (error "Can't list tops-20 devices"))
127 ((string-match "/[^:/]+:/$" dir-path)
128 (error "Can't list all root directories on a tops-20 device"))
129 ((efs-fix-path 'tops-20 dir-path nil))))
130
131
132 ;; In tops-20 listings, the filename starts immediatley after the date regexp.
133
134 (defconst efs-tops-20-date-regexp
135 (concat
136 " [1-3]?[0-9]-\\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct"
137 "\\|Nov\\|Dec\\)-[0-9][0-9] [0-9][0-9]:[0-9][0-9]:[0-9][0-9] "))
138
139
140 (efs-defun efs-parse-listing tops-20
141 (host user dir path &optional switches)
142 ;; Parse the current buffer which is assumed to be a TOPS-20 directory
143 ;; listing, and return a hashtable as the result.
144 ;; HOST = remote host name
145 ;; USER = user name
146 ;; DIR = directory in as a full remote path
147 ;; PATH = directory in full efs path syntax
148 ;; SWITCHES = ls switches (not relevant here)
149 (let ((tbl (efs-make-hashtable))
150 file)
151 (goto-char (point-min))
152 (efs-save-match-data
153 (if (looking-at " *[^/:]+:<\\([^/.<>]+\\.\\)+> *$")
154 ;; looking at the directory name
155 (forward-line 1))
156 (while (re-search-forward efs-tops-20-date-regexp nil t)
157 (setq file (buffer-substring (point)
158 (progn (end-of-line) (point))))
159 (if (string-match "\\.DIRECTORY\\.[0-9]+$" file)
160 ;; deal with directories
161 (efs-put-hash-entry
162 (substring file 0 (match-beginning 0)) '(t) tbl)
163 (efs-put-hash-entry file '(nil) tbl)
164 ;; sans extension
165 (if (string-match "\\.[0-9]+$" file)
166 (efs-put-hash-entry
167 (substring file 0 (match-beginning 0)) '(nil) tbl)))
168 (forward-line 1))
169 (efs-put-hash-entry "." '(t) tbl)
170 (efs-put-hash-entry ".." '(t) tbl))
171 tbl))
172
173 (efs-defun efs-really-file-p tops-20 (file ent)
174 ;; Eliminates the version entries
175 (or (car ent) ; file-directory-p
176 (efs-save-match-data
177 (string-match "\\.[0-9]+$" file))))
178
179 (efs-defun efs-delete-file-entry tops-20 (path &optional dir-p)
180 (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types)))
181 (if dir-p
182 (let ((path (file-name-as-directory path))
183 files)
184 (efs-del-hash-entry path efs-files-hashtable ignore-case)
185 (setq path (directory-file-name path)
186 files (efs-get-hash-entry (file-name-directory path)
187 efs-files-hashtable
188 ignore-case))
189 (if files
190 (efs-del-hash-entry (efs-get-file-part path)
191 files ignore-case)))
192 (efs-save-match-data
193 (let ((file (efs-get-file-part path)))
194 (if (string-match "\\.[0-9]+$" file)
195 ;; Only delete explicit versions
196 (let ((files (efs-get-hash-entry
197 (file-name-directory path)
198 efs-files-hashtable ignore-case)))
199 (if files
200 (let ((root (substring file 0
201 (match-beginning 0)))
202 (completion-ignore-case ignore-case)
203 (len (match-beginning 0)))
204 (efs-del-hash-entry file files ignore-case)
205 ;; Now we need to check if there are any
206 ;; versions left. If not, then delete the
207 ;; root entry.
208 (or (all-completions
209 root files
210 (function
211 (lambda (sym)
212 (string-match "\\.[0-9]+$"
213 (symbol-name sym) len))))
214 (efs-del-hash-entry root files
215 ignore-case)))))))))
216 (efs-del-from-ls-cache path t ignore-case)))
217
218 (efs-defun efs-add-file-entry tops-20
219 (path dir-p size owner &optional modes nlinks mdtm)
220 ;; The tops-20 version of this function needs to keep track
221 ;; of tops-20's file versions.
222 (let ((ignore-case (memq 'tops-20 efs-case-insensitive-host-types))
223 (ent (let ((dir-p (null (null dir-p))))
224 (if mdtm
225 (list dir-p size owner nil nil mdtm)
226 (list dir-p size owner)))))
227 (if dir-p
228 (let* ((path (directory-file-name path))
229 (files (efs-get-hash-entry (file-name-directory path)
230 efs-files-hashtable
231 ignore-case)))
232 (if files
233 (efs-put-hash-entry (efs-get-file-part path)
234 ent files ignore-case)))
235 (let ((files (efs-get-hash-entry
236 (file-name-directory path)
237 efs-files-hashtable ignore-case)))
238 (if files
239 (let ((file (efs-get-file-part path)))
240 (efs-save-match-data
241 (if (string-match "\\.[0-9]+$" file)
242 (efs-put-hash-entry
243 (substring file 0 (match-beginning 0))
244 ent files ignore-case)
245 ;; Need to figure out what version of the file
246 ;; is being added.
247 (let* ((completion-ignore-case ignore-case)
248 (len (length file))
249 (versions (all-completions
250 file files
251 (function
252 (lambda (sym)
253 (string-match "\\.[0-9]+$"
254 (symbol-name sym) len)))))
255 (N (1+ len))
256 (max (apply
257 'max
258 (cons 0 (mapcar
259 (function
260 (lambda (x)
261 (string-to-int (substring x N))))
262 versions)))))
263 ;; No need to worry about case here.
264 (efs-put-hash-entry
265 (concat file "." (int-to-string (1+ max))) ent files))))
266 (efs-put-hash-entry file ent files ignore-case)))))
267 (efs-del-from-ls-cache path t ignore-case)))
268
269 (efs-defun efs-internal-file-name-as-directory tops-20 (name)
270 (efs-save-match-data
271 (if (string-match "\\.DIRECTORY\\(\\.[0-9>]\\)?$" name)
272 (setq name (substring name 0 (match-beginning 0))))
273 (let (file-name-handler-alist)
274 (file-name-as-directory name))))
275
276 ;;; Tree Dired
277
278 (defconst efs-dired-tops-20-re-dir
279 "^[^\n]+\\.DIRECTORY\\(\\.[0-9]+\\)?$")
280
281 (or (assq 'tops-20 efs-dired-re-dir-alist)
282 (setq efs-dired-re-dir-alist
283 (cons (cons 'tops-20 efs-dired-tops-20-re-dir)
284 efs-dired-re-dir-alist)))
285
286
287 (efs-defun efs-dired-manual-move-to-filename tops-20
288 (&optional raise-error bol eol)
289 ;; In dired, move to first char of filename on this line.
290 ;; Returns position (point) or nil if no filename on this line.
291 ;; This is the Tops-20 version.
292 (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
293 (let (case-fold-search)
294 (if bol
295 (goto-char bol)
296 (skip-chars-backward "^\n\r"))
297 (if (re-search-forward efs-tops-20-date-regexp eol t)
298 (point)
299 (and raise-error (error "No file on this line")))))
300
301 (efs-defun efs-dired-manual-move-to-end-of-filename tops-20
302 (&optional no-error bol eol)
303 ;; Assumes point is at beginning of filename.
304 ;; So, it should be called only after (dired-move-to-filename t).
305 ;; On failure, signals an error or returns nil.
306 ;; This is the Tops-20 version.
307 (let ((opoint (point)))
308 (and selective-display
309 (null no-error)
310 (eq (char-after
311 (1- (or bol (save-excursion
312 (skip-chars-backward "^\r\n")
313 (point)))))
314 ?\r)
315 ;; File is hidden or omitted.
316 (cond
317 ((dired-subdir-hidden-p (dired-current-directory))
318 (error
319 (substitute-command-keys
320 "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
321 ((error
322 (substitute-command-keys
323 "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
324 )))))
325 ;; Is this the right character set?
326 (skip-chars-forward "-_A-Z0-9$.;")
327 (if (or (= opoint (point)) (not (memq (following-char) '(?\n ?\r))))
328 (if no-error
329 nil
330 (error "No file on this line"))
331 (point))))
332
333 (efs-defun efs-internal--file-name-sans-versions tops-20
334 (name &optional keep-backup-version)
335 (efs-save-match-data
336 (if (string-match "\\.[0-9]+$" name)
337 (substring name 0 (match-beginning 0))
338 name)))
339
340 (efs-defun efs-dired-insert-headerline tops-20 (dir)
341 ;; TOPS-20 inserts a headerline. I would prefer the headerline
342 ;; to be in efs format. This version tries to
343 ;; be careful, because we can't count on a headerline
344 ;; over ftp, and we wouldn't want to delete anything
345 ;; important.
346 (save-excursion
347 (if (looking-at "^ wildcard ")
348 (forward-line 1))
349 (if (looking-at "^[ \n\t]*[^:/<>]+:<[^<>/]+> *\n")
350 (delete-region (point) (match-end 0)))
351 (insert " " (directory-file-name dir) ":\n\n")))
352
353 ;;; end of efs-tops-20.el