--- /dev/null	Thu Jan 01 00:00:00 1970 +0000
+++ b/lisp/efs/efs-cms.el	Mon Aug 13 08:50:29 2007 +0200
@@ -0,0 +1,462 @@
+;; -*-Emacs-Lisp-*-
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;
+;; File:         efs-cms.el
+;; Release:      $efs release: 1.15 $
+;; Version:      $Revision: 1.1 $
+;; 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 warrranty (there isn't one) information.
+
+(provide 'efs-cms)
+(require 'efs)
+
+(defconst efs-cms-version
+  (concat (substring "$efs release: 1.15 $" 14 -2)
+	  "/"
+	  (substring "$Revision: 1.1 $" 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)) (/= (following-char) ?\ ))
+	(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