Mercurial > hg > xemacs-beta

comparison lisp/efs/efs-mts.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
comparison
equal deleted inserted replaced
21:b88636d63495 22:8fc7fe29b841
1 ;; -*-Emacs-Lisp-*-
2 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
3 ;;
4 ;; File: efs-mts.el
5 ;; Release: $efs release: 1.15 $
6 ;; Version: $Revision: 1.1 $
7 ;; RCS:
8 ;; Description: MTS support for efs
9 ;; Author: Sandy Rutherford <sandy@itp.ethz.ch>
10 ;; Created: Fri Oct 23 08:51:29 1992
11 ;; Modified: Sun Nov 27 18:37:18 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-mts)
20 (require 'efs)
21
22 (defconst efs-mts-version
23 (concat (substring "$efs release: 1.15 $" 14 -2)
24 "/"
25 (substring "$Revision: 1.1 $" 11 -2)))
26
27 ;;;; ------------------------------------------------------------
28 ;;;; MTS support
29 ;;;; ------------------------------------------------------------
30
31 ;;; efs has full support, including tree dired support, for hosts running
32 ;;; the Michigan terminal system. It should be able to automatically
33 ;;; recognize any MTS machine. We would be grateful if you
34 ;;; would report any failures to automatically recognize a MTS host as a bug.
35 ;;;
36 ;;; Filename syntax:
37 ;;;
38 ;;; MTS filenames are entered in a UNIX-y way. For example, if your account
39 ;;; was YYYY, the file FILE in the account XXXX: on mtsg.ubc.ca would be
40 ;;; entered as
41 ;;; /YYYY@mtsg.ubc.ca:/XXXX:/FILE
42 ;;; In other words, MTS accounts are treated as UNIX directories. Of course,
43 ;;; to access a file in another account, you must have access permission for
44 ;;; it. If FILE were in your own account, then you could enter it in a
45 ;;; relative path fashion as
46 ;;; /YYYY@mtsg.ubc.ca:FILE
47 ;;; MTS filenames can be up to 12 characters. Like UNIX, the structure of the
48 ;;; filename does not contain a TYPE (i.e. it can have as many "."'s as you
49 ;;; like.) MTS filenames are always in upper case, and hence be sure to enter
50 ;;; them as such! MTS is not case sensitive, but an EMACS running under UNIX
51 ;;; is.
52
53
54 (defconst efs-mts-date-regexp
55 (concat
56 " \\(Jan\\|Feb\\|Mar\\|Apr\\|May\\|Jun\\|Jul\\|Aug\\|Sep\\|Oct"
57 "\\|Nov\\|Dec\\) [ 123]?[0-9] "))
58
59 ;;; The following two functions are entry points to this file.
60 ;;; They are put into the appropriate alists in efs.el
61
62 (efs-defun efs-fix-path mts (path &optional reverse)
63 ;; Convert PATH from UNIX-ish to MTS.
64 ;; If REVERSE given then convert from MTS to UNIX-ish.
65 (efs-save-match-data
66 (if reverse
67 (if (string-match "^\\([^:]+:\\)?\\(.*\\)$" path)
68 (let (acct file)
69 (if (match-beginning 1)
70 (setq acct (substring path 0 (match-end 1))))
71 (if (match-beginning 2)
72 (setq file (substring path
73 (match-beginning 2) (match-end 2))))
74 (concat (and acct (concat "/" acct "/"))
75 file))
76 (error "path %s didn't match" path))
77 (if (string-match "^/\\([^:]+:\\)/\\(.*\\)$" path)
78 (concat (substring path 1 (match-end 1))
79 (substring path (match-beginning 2) (match-end 2)))
80 ;; Let's hope that mts will recognize it anyway.
81 path))))
82
83 (efs-defun efs-fix-dir-path mts (dir-path)
84 ;; Convert path from UNIX-ish to MTS ready for a DIRectory listing.
85 ;; Remember that there are no directories in MTS.
86 (if (string-equal dir-path "/")
87 (error "Cannot get listing for fictitious \"/\" directory.")
88 (let ((dir-path (efs-fix-path 'mts dir-path)))
89 (cond
90 ((string-equal dir-path "")
91 "?")
92 ((efs-save-match-data (string-match ":$" dir-path))
93 (concat dir-path "?"))
94 (dir-path))))) ; It's just a single file.
95
96
97 (efs-defun efs-parse-listing mts
98 (host user dir path &optional switches)
99 ;; Parse the current buffer which is assumed to be in
100 ;; mts ftp dir format.
101 ;; HOST = remote host name
102 ;; USER = remote user name
103 ;; DIR = remote directory as a remote full path
104 ;; PATH = directory as an efs full path
105 ;; SWITCHES are never used here, but they
106 ;; must be specified in the argument list for compatibility
107 ;; with the unix version of this function.
108 (let ((tbl (efs-make-hashtable))
109 perms)
110 (goto-char (point-min))
111 (efs-save-match-data
112 (while (re-search-forward efs-mts-date-regexp nil t)
113 (beginning-of-line)
114 (if (looking-at "[rwed]+")
115 (setq perms (buffer-substring (match-beginning 0) (match-end 0)))
116 (setq perms nil))
117 (end-of-line)
118 (skip-chars-backward " ")
119 (let ((end (point)))
120 (skip-chars-backward "-A-Z0-9_.!")
121 (efs-put-hash-entry (buffer-substring (point) end)
122 (list nil nil nil perms) tbl))
123 (forward-line 1)))
124 ;; Don't need to bother with ..
125 (efs-put-hash-entry "." '(t) tbl)
126 tbl))
127
128 (efs-defun efs-allow-child-lookup mts (host user dir file)
129 ;; Returns t if FILE in directory DIR could possibly be a subdir
130 ;; according to its file-name syntax, and therefore a child listing should
131 ;; be attempted.
132
133 ;; MTS file system is flat. Only "accounts" are subdirs.
134 (string-equal "/" dir))
135
136 (efs-defun efs-internal-file-writable-p mts (user owner modes)
137 (if (stringp modes)
138 (efs-save-match-data
139 (null (null (string-match "w" modes))))
140 t)) ; guess
141
142 (efs-defun efs-internal-file-readable-p mts (user owner modes)
143 (if (stringp modes)
144 (efs-save-match-data
145 (null (null (string-match "r" modes))))
146 t)) ; guess
147
148 ;;; Tree dired support:
149
150 ;; There aren't too many systems left that use MTS. This dired support will
151 ;; work for the implementation of ftp on mtsg.ubc.ca. I hope other mts systems
152 ;; implement ftp in the same way. If not, it might be necessary to make the
153 ;; following more flexible.
154
155 (defconst efs-dired-mts-re-exe nil)
156
157 (or (assq 'mts efs-dired-re-exe-alist)
158 (setq efs-dired-re-exe-alist
159 (cons (cons 'mts efs-dired-mts-re-exe)
160 efs-dired-re-exe-alist)))
161
162 (defconst efs-dired-mts-re-dir nil)
163
164 (or (assq 'mts efs-dired-re-dir-alist)
165 (setq efs-dired-re-dir-alist
166 (cons (cons 'mts efs-dired-mts-re-dir)
167 efs-dired-re-dir-alist)))
168
169 (efs-defun efs-dired-manual-move-to-filename mts
170 (&optional raise-error bol eol)
171 ;; In dired, move to first char of filename on this line.
172 ;; Returns position (point) or nil if no filename on this line.
173 ;; This is the MTS version.
174 (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
175 (if bol
176 (goto-char bol)
177 (skip-chars-backward "^\n\r"))
178 (if (re-search-forward efs-mts-date-regexp eol t)
179 (progn
180 (skip-chars-forward " ") ; Eat blanks after date
181 (skip-chars-forward "0-9:") ; Eat time or year
182 (skip-chars-forward " ") ; one space before filename
183 (point))
184 (and raise-error (error "No file on this line"))))
185
186 (efs-defun efs-dired-manual-move-to-end-of-filename mts
187 (&optional no-error bol eol)
188 ;; Assumes point is at beginning of filename.
189 ;; So, it should be called only after (dired-move-to-filename t).
190 ;; On failure, signals an error or returns nil.
191 ;; This is the MTS version.
192 (let ((opoint (point)))
193 (and selective-display
194 (null no-error)
195 (eq (char-after
196 (1- (or bol (save-excursion
197 (skip-chars-backward "^\r\n")
198 (point)))))
199 ?\r)
200 ;; File is hidden or omitted.
201 (cond
202 ((dired-subdir-hidden-p (dired-current-directory))
203 (error
204 (substitute-command-keys
205 "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
206 ((error
207 (substitute-command-keys
208 "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
209 )))))
210 (skip-chars-forward "-A-Z0-9._!")
211 (if (or (= opoint (point)) (not (memq (following-char) '(?\r ?\n))))
212 (if no-error
213 nil
214 (error "No file on this line"))
215 (point))))
216
217 (efs-defun efs-dired-fixup-listing mts (file path &optional switches wildcard)
218 ;; If you're not listing your own account, MTS puts the
219 ;; account name in front of each filename. Scrape them off.
220 ;; PATH will have unix /'s on it.
221 ;; file-name-directory is in case of wildcards
222 (let ((len (length path)))
223 (if (> len 2)
224 (progn
225 (if (= (aref path (1- len)) ?/)
226 (setq path (substring path -2))
227 (setq path (substring path -1)))
228 (goto-char (point-min))
229 (while (search-forward path nil t)
230 (delete-region (match-beginning 0) (match-end 0)))))))
231
232 (efs-defun efs-dired-insert-headerline mts (dir)
233 ;; MTS has no total line, so we insert a blank line for
234 ;; aesthetics.
235 (insert "\n")
236 (forward-char -1)
237 (efs-real-dired-insert-headerline dir))
238
239 ;;; end of efs-mts.el