Source

efs / efs-cms.el

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
;; -*-Emacs-Lisp-*-
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; File:         efs-cms.el
;; Release:      $efs release: 1.22 $
;; Version:      #Revision: 1.9 $
;; RCS:          
;; Description:  CMS support for efs
;; Author:       Sandy Rutherford <sandy@ibm550.sissa.it>
;; Created:      Fri Oct 23 08:52:00 1992
;; Modified:     Sun Nov 27 11:46:51 1994 by sandy on gandalf
;; Language:     Emacs-Lisp
;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;; This file is part of efs. See efs.el for copyright
;;; (it's copylefted) and warranty (there isn't one) information.

(provide 'efs-cms)
(require 'efs)

(defconst efs-cms-version
  (concat (substring "$efs release: 1.22 $" 14 -2)
	  "/"
	  (substring "#Revision: 1.9 $" 11 -2)))

;;;; ------------------------------------------------------------
;;;; CMS support
;;;; ------------------------------------------------------------

;;; efs has full support, including tree dired support, for hosts running
;;; CMS.  It should be able to automatically recognize any CMS machine.
;;; We would be grateful if you would report any failures to automatically
;;; recognize a CMS host as a bug.
;;; 
;;; This should also work with CMS machines running SFS (Shared File System).
;;; 
;;; Filename syntax:
;;;
;;; CMS filenames are entered in a UNIX-y way. In otherwords, minidisks are
;;; treated as UNIX directories. For example to access the file READ.ME in
;;; minidisk *.311 on cuvmb.cc.columbia.edu, you would enter
;;;   /anonymous@cuvmb.cc.columbia.edu:/*.311/READ.ME
;;; If *.301 is the default minidisk for this account, you could access
;;; FOO.BAR on this minidisk as
;;;   /anonymous@cuvmb.cc.columbia.edu:FOO.BAR
;;; CMS filenames are of the form FILE.TYPE, where both FILE and TYPE can be
;;; up to 8 characters. Again, beware that CMS filenames are always upper
;;; case, and hence must be entered as such.
;;;
;;; Tips:
;;; 1. CMS machines, with the exception of anonymous accounts, nearly always
;;;    need an account password. To have efs send an account password,
;;;    you can either include it in your .netrc file, or use
;;;    efs-set-account.
;;; 2. efs-set-account can be used to set account passwords for specific
;;;    minidisks. This is usually used to optain write access to the minidisk.
;;;    As well you can put tokens of the form
;;;    minidisk <minidisk name> <password> in your .netrc file. There can be
;;;    as many minidisk tokens as you like, however they should follow all
;;;    other tokens for a given machine entry. Of course, ordinary ftp
;;;    will not understand these entries in your .netrc file.
;;;


;;; Since CMS doesn't have any full pathname syntax, we have to fudge
;;; things with cd's. We actually send too many cd's, but is dangerous
;;; to try to remember the current minidisk, because if the connection
;;; is closed and needs to be reopened, we will find ourselves back in
;;; the default minidisk. This is fairly likely since CMS ftp servers
;;; usually close the connection after 5 minutes of inactivity.

;;; Have I got the filename character set right?

;;; The following three functions are entry points to this file.
;;; They have been added to the appropriate alists in efs.el

(efs-defun efs-fix-path cms (path &optional reverse)
  ;; Convert PATH from UNIX-ish to CMS. If REVERSE is given, convert
  ;; from CMS to UNIX. Actually, CMS doesn't have a full pathname syntax,
  ;; so we fudge things by sending cd's.
  (efs-save-match-data
    (if reverse
	(if (string-match ":" path)
	    ;; It's SFS
	    (let* ((start (match-end 0))
		   (return (concat "/" (substring path 0 start))))
	      (while (string-match "\\." path start)
		(setq return (concat return "/"
				     (substring path start
						(match-beginning 0)))
		      start (match-end 0)))
	      (concat return "/" (substring path start)))
	  ;; Since we only convert output from a pwd in this direction,
	  ;; we'll assume that it's a minidisk, and make it into a
	  ;; directory file name. Note that the expand-dir-hashtable
	  ;; stores directories without the trailing /.
	  (if (char-equal (string-to-char path) ?/)
	      path
	    (concat "/" path)))
      (if (let ((case-fold-search t))
	    (string-match
	     (concat
	      "^/\\([-A-Z0-9$*._+:]+\\)/"
	      ;; In case there is a SFS
	      "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?"
	      "\\([-A-Z0-9$._+]+\\)$")
	     path))
	  (let ((minidisk (substring path 1 (match-end 1)))
		(sfs (and (match-beginning 2)
			  (substring path (match-beginning 3)
				     (match-end 3))))
		(file (substring path (match-beginning 5) (match-end 5)))
		account)
	    (and sfs (match-beginning 4)
		 (setq sfs (concat sfs "." (substring path (match-beginning 4)
						      (1- (match-end 4))))))
	    (unwind-protect
		(progn
		  (or sfs
		      (setq account
			    (efs-get-account host user minidisk)))
		  (efs-raw-send-cd host user (if sfs
						 (concat minidisk sfs ".")
					       minidisk))
		  (if account
		      (efs-cms-send-minidisk-acct
		       host user minidisk account)))
	      (if account (fillarray account 0)))
	    file)
	(error "Invalid CMS filename")))))

(efs-defun efs-fix-dir-path cms (dir-path)
  ;; Convert path from UNIX-ish to VMS ready for a DIRectory listing.
  (efs-save-match-data
    (cond
     ((string-equal "/" dir-path)
      (error "Cannot get listing for CMS \"/\" directory."))
     ((let ((case-fold-search t))
	(string-match
	 (concat "^/\\([-A-Z0-9$*._+:]+\\)/"
		 "\\(\\([-A-Z0-9$*._+]+\\)/\\([-A-Z0-9$*._+]+/\\)?\\)?"
		 "\\([-A-Z0-9$*_.+]+\\)?$") dir-path))
      (let ((minidisk (substring dir-path (match-beginning 1) (match-end 1)))
	    (sfs (and (match-beginning 2)
		      (concat
		       (substring dir-path (match-beginning 3)
				  (match-end 3)))))
	    (file (if (match-beginning 5)
		      (substring dir-path (match-beginning 5) (match-end 5))
		    "*"))
	    account)
	(and sfs (match-beginning 4)
	     (setq sfs (concat sfs "." (substring dir-path
						  (match-beginning 4)
						  (1- (match-end 4))))))
	(unwind-protect
	    (progn
	      (or sfs
		  (setq account (efs-get-account host user minidisk)))
	      (efs-raw-send-cd host user (if sfs
					     (concat minidisk sfs ".")
					     minidisk))
	      (if account
		  (efs-cms-send-minidisk-acct host user minidisk account)))
	  (if account (fillarray account 0)))
	file))
     (t (error "Invalid CMS pathname")))))

(defconst efs-cms-file-line-regexp
  (concat
   "\\([-A-Z0-9$_+]+\\) +"
   "\\(\\(\\([-A-Z0-9$_+]+\\) +[VF] +[0-9]+ \\)\\|\\(DIR +- \\)\\)"))

(efs-defun efs-parse-listing cms
  (host user dir path &optional switches)
  ;; Parse the current buffer which is assumed to be a CMS directory listing.
  ;; HOST = remote host name
  ;; USER = remote user name
  ;; DIR = directory as a full remote path
  ;; PATH = directory as a full efs-path
  (let ((tbl (efs-make-hashtable))
	fn dir-p)
    (goto-char (point-min))
    (efs-save-match-data
      (while (re-search-forward efs-cms-file-line-regexp nil t)
	(if (match-beginning 3)
	    (setq fn (concat (buffer-substring
			      (match-beginning 1) (match-end 1))
			     "."
			     (buffer-substring
			      (match-beginning 4) (match-end 4)))
		  dir-p nil)
	  (setq fn (buffer-substring (match-beginning 1) (match-end 1))
		dir-p t))
	(efs-put-hash-entry fn (list dir-p) tbl)
	(forward-line 1))
      (efs-put-hash-entry "." '(t) tbl)
      (efs-put-hash-entry ".." '(t) tbl))
    tbl))

(defun efs-cms-send-minidisk-acct (host user minidisk account
					&optional noretry)
  "For HOST and USER, send the account password ACCOUNT. If MINIDISK is given,
the account password is for that minidisk. If PROC is given, send to that
process, rathr than use HOST and USER to look up the process."
  (efs-save-match-data
    (let ((result (efs-raw-send-cmd
		   (efs-get-process host user)
		   (concat "quote acct " account))))
      (cond
       ((eq (car result) 'failed)
	(setq account nil)
	(unwind-protect
	    (progn
	      (setq
	       account
	       (read-passwd
		(format
		 "Invalid acct. password for %s on %s@%s. Try again: "
		 minidisk user host)))
	      (if (string-equal "" account)
		  (setq account nil)))
	  ;; This guarantees that an interrupt will clear the account
	  ;; password.
	  (efs-set-account host user minidisk account))
	(if account ; give the user another chance
	    (efs-cms-send-minidisk-acct host user minidisk account)))
       ((eq (car result) 'fatal)
	(if noretry
	    ;; give up
	    (efs-error host user
		       (concat "ACCOUNT password failed: " (nth 1 result)))
	  ;; try once more
	  (efs-cms-send-minidisk-acct host user minidisk account t))))
      ;; return result
      result)))

(efs-defun efs-write-recover cms
  (line cont-lines host user cmd msg pre-cont cont nowait noretry)
  ;; If a write fails because of insufficient privileges, give the user a
  ;; chance to send an account password.
  (let ((cmd0 (car cmd))
	(cmd1 (nth 1 cmd))
	(cmd2 (nth 2 cmd)))
    (efs-save-match-data
      (if (and (or (memq cmd0 '(append put rename))
		   (and (eq cmd0 'quote) (eq cmd1 'stor)))
	       (string-match "^/\\([-A-Z0-9$*._+]+\\)/[-A-Z0-9$*._+]+$" cmd2))
	  (let ((minidisk (substring cmd2 (match-beginning 1) (match-end 1)))
		account retry)
	    (unwind-protect
		(progn
		  (setq account
			(read-passwd
			 (format "Account password for minidisk %s on %s@%s: "
				 minidisk user host)))
		  (if (string-equal account "")
		      (setq account nil)))
	      (efs-set-account host user minidisk account))
	    (if account
		(progn
		  (efs-cms-send-minidisk-acct host user minidisk account)
		  (setq retry
			(efs-send-cmd host user cmd msg pre-cont cont
				      nowait noretry))
		  (and (null (or cont nowait)) retry))
	      (if cont
		  (progn
		    (efs-call-cont cont 'failed line cont-lines)
		    nil)
		(and (null nowait) (list 'failed line cont-lines)))))
	(if cont
	    (progn
	      (efs-call-cont cont 'failed line cont-lines)
	      nil)
	  (and (null nowait) (list 'failed line cont-lines)))))))

(efs-defun efs-allow-child-lookup cms (host user dir file)
  ;; Returns t if FILE in directory DIR could possibly be a subdir
  ;; according to its file-name syntax, and therefore a child listing should
  ;; be attempted.
  
  ;; CMS file system is flat. Only minidisks are "subdirs".
  (or (string-equal "/" dir)
      (efs-save-match-data
	(string-match "^/[^/:]+:/$" dir))))

;;; Sorting listings

(defconst efs-cms-date-and-time-regexp
  (concat
   " \\(1?[0-9]\\)/\\([0-3][0-9]\\)/\\([0-9][0-9]\\) +"
   "\\([12]?[0-9]\\):\\([0-5][0-9]\\):\\([0-5][0-9]\\) "))

(efs-defun efs-t-converter cms (&optional regexp reverse)
  (if regexp
      nil
    (goto-char (point-min))
    (efs-save-match-data
      (if (re-search-forward efs-cms-date-and-time-regexp nil t)
	  (let (list-start list bol nbol)
	    (beginning-of-line)
	    (setq list-start (point))
	    (while (progn
		     (setq bol (point))
		     (re-search-forward efs-cms-date-and-time-regexp
					(setq nbol (save-excursion
						     (forward-line 1) (point)))
					t))
	      (setq list
		    (cons
		     (cons
		      (list (string-to-int (buffer-substring
					    (match-beginning 3)
					    (match-end 3))) ; year
			    (string-to-int (buffer-substring
					    (match-beginning 1)
					    (match-end 1))) ; month
			    (string-to-int (buffer-substring
					    (match-beginning 2)
					    (match-end 2))) ; day
			    (string-to-int (buffer-substring
					    (match-beginning 4)
					    (match-end 4))) ; hour
			    (string-to-int (buffer-substring
					    (match-beginning 5)
					    (match-end 5))) ; minutes
			    (string-to-int (buffer-substring
					    (match-beginning 6)
					    (match-end 6)))) ; seconds
		      (buffer-substring bol nbol))
		     list))
	      (goto-char nbol))
	    (if list
		(progn
		  (setq list
			(mapcar 'cdr
				(sort list 'efs-cms-t-converter-sort-pred)))
		  (if reverse (setq list (nreverse list)))
		  (delete-region list-start (point))
		  (apply 'insert list)))
	    t)))))

(defun efs-cms-t-converter-sort-pred (elt1 elt2)
  (let* ((data1 (car elt1))
	 (data2 (car elt2))
	 (year1 (car data1))
	 (year2 (car data2))
	 (month1 (nth 1 data1))
	 (month2 (nth 1 data2))
	 (day1 (nth 2 data1))
	 (day2 (nth 2 data2))
	 (hour1 (nth 3 data1))
	 (hour2 (nth 3 data2))
	 (minute1 (nth 4 data1))
	 (minute2 (nth 4 data2))
	 (second1 (nth 5 data1))
	 (second2 (nth 5 data2)))
    (or (> year1 year2)
	(and (= year1 year2)
	     (or (> month1 month2)
		 (and (= month1 month2)
		      (or (> day1 day2)
			  (and (= day1 day2)
			       (or (> hour1 hour2)
				   (and (= hour1 hour2)
					(or (> minute1 minute2)
					    (and (= minute1 minute2)
						 (or (> (nth 5 data1)
							(nth 5 data2)))
						 ))))))))))))


;;; Tree dired support:

(defconst efs-dired-cms-re-exe "^. [-A-Z0-9$_+]+ +EXEC ")

(or (assq 'cms efs-dired-re-exe-alist)
    (setq efs-dired-re-exe-alist
	  (cons (cons 'cms  efs-dired-cms-re-exe)
		efs-dired-re-exe-alist)))

(defconst efs-dired-cms-re-dir "^. [-A-Z0-9$_+]+ +DIR ")

(or (assq 'cms efs-dired-re-dir-alist)
    (setq efs-dired-re-dir-alist
	  (cons (cons 'cms  efs-dired-cms-re-dir)
		efs-dired-re-dir-alist)))

(efs-defun efs-dired-insert-headerline cms (dir)
  ;; CMS has no total line, so we insert a blank line for
  ;; aesthetics.
  (insert "\n")
  (forward-char -1)
  (efs-real-dired-insert-headerline dir))

(efs-defun efs-dired-manual-move-to-filename cms
  (&optional raise-error bol eol)
  ;; In dired, move to the first char of filename on this line.
  ;; This is the CMS version.
  (or eol (setq eol (save-excursion (skip-chars-forward "^\n\r") (point))))
  (let (case-fold-search)
    (if bol
	(goto-char bol)
      (skip-chars-backward "^\n\r")
      (setq bol (point)))
    (if (re-search-forward efs-cms-file-line-regexp eol t)
	(goto-char (match-beginning 0))
      (goto-char bol)
      (and raise-error (error "No file on this line")))))

(efs-defun efs-dired-manual-move-to-end-of-filename cms
  (&optional no-error bol eol)
  ;; Assumes point is at beginning of filename.
  ;; So, it should be called only after (dired-move-to-filename t).
  ;; case-fold-search must be nil, at least for VMS.
  ;; On failure, signals an error or returns nil.
  ;; This is the CMS version.
  (let ((opoint (point)))
    (and selective-display
	 (null no-error)
	 (eq (char-after
	      (1- (or bol (save-excursion
			    (skip-chars-backward "^\r\n")
			    (point)))))
	     ?\r)
	 ;; File is hidden or omitted.
	 (cond
	  ((dired-subdir-hidden-p (dired-current-directory))
	   (error
	    (substitute-command-keys
	     "File line is hidden. Type \\[dired-hide-subdir] to unhide.")))
	  ((error
	    (substitute-command-keys
	     "File line is omitted. Type \\[dired-omit-toggle] to un-omit."
	     )))))
    (skip-chars-forward "-A-Z0-9$_+")
    (or (looking-at " +DIR ")
	(progn
	  (skip-chars-forward " ")
	  (skip-chars-forward "-A-Z0-9$_+")))
    (if (or (= opoint (point)) (/= (char-after (point)) ?\ ))
	(if no-error
	    nil
	  (error "No file on this line"))
      (point))))

(efs-defun efs-dired-make-filename-string cms (filename &optional reverse)
  (if reverse
      (if (string-match "\\." filename)
	  ;; Can't count on the number of blanks between the base and the
	  ;; extension, so ignore the extension.
	  (substring filename 0 (match-beginning 0))
	filename)
    (if (string-match "^\\([^ ]+\\) +\\([^ ]+\\)$" filename)
	(concat (substring filename 0 (match-end 1))
		"."
		(substring filename (match-beginning 2) (match-end 2)))
      filename)))

;;; end of efs-cms.el
Tip: Filter by directory path e.g. /media app.js to search for public/media/app.js.
Tip: Use camelCasing e.g. ProjME to search for ProjectModifiedEvent.java.
Tip: Filter by extension type e.g. /repo .js to search for all .js files in the /repo directory.
Tip: Separate your search with spaces e.g. /ssh pom.xml to search for src/ssh/pom.xml.
Tip: Use ↑ and ↓ arrow keys to navigate and return to view the file.
Tip: You can also navigate files with Ctrl+j (next) and Ctrl+k (previous) and view the file with Ctrl+o.
Tip: You can also navigate files with Alt+j (next) and Alt+k (previous) and view the file with Alt+o.