saraiya@SUMEX-AIM.STANFORD.EDU (Nakul P. Saraiya) (12/01/89)
Has anyone modified ZMACS to keep "backup" (~) versions of files on UNIX systems (like gnuemacs does)? nakul
cerys@BBN.COM (Dan Cerys) (12/02/89)
This is a great feature that I'd love to see on the Explorer. There is an alternative (also supported by GNU emacs) that provides for version numbers for less-than-the-newest version (this is more useful for LISPM folks, I believe). The right place to do this support is in the pathname system, not in Zmacs. That way all applications can take advantage of it. Essentially, doing this would provide a new host-pathname type of UNIX-with-Versions. Since systems on the Explorer already know how to use versions, everybody is happy. See GNU Emacs if you're curious about the syntax used. Let us all know if somebody does this (or has done it).
jamey@AU-BON-PAIN.LCS.MIT.EDU (Jamey Hicks) (12/02/89)
Has anyone modified ZMACS to keep "backup" (~) versions of files on UNIX
systems (like gnuemacs does)?
nakul
[sorry if you get this twice, I'm not sure if my previous attempt at
posting succeeded].
Yes, I've done this. But first, did you know that the explorers
normally delete the file on the Unix host first, and then write the new
version? I thought this was a loss (especially when my machine croaked
after deleting the old version but before writing the new version).
This code exists in the current TI release, but it's broken.
The change is mode to the FTP open method so that it will work any time
the Explorer writes files to the Unix host.
Here it is:
;;; -*- Mode:Common-Lisp; Package:FILE-SYSTEM; Patch-file:T; Base:10 -*-
(in-package "FS")
(DEFUN bastardize-filename (pathobj &aux type)
;; Take a file name and create a variation by replacing the last four characters by an arbitrary string.
;; If the file name is less than four characters, at least two leading characters will be retained.
;; This routine makes the assumption that any file system allows names to be at least six characters long
;; and contain capital letters.
(SETQ type (SEND pathobj :type))
;; for file systems with versioning, use :newest
(cond ((or (null type) (EQ (SEND pathobj :type) :unspecific))
(send pathobj :new-pathname :name (string-append (pathname-name pathobj) "~")))
(t
(SEND pathobj :new-pathname :type (STRING-APPEND type "~"
) :version :newest))))
;;;---- FTP-OPEN
(DEFUN ftp-open (PATHNAME &rest options &key (direction :input) (characters :default)
(element-type 'STRING-CHAR element-type-p) (BYTE-SIZE :default)
(if-exists
(or (getf options :if-exists)
(WHEN (EQ direction :output)
(IF (MEMBER (PATHNAME-VERSION pathname) '(:newest :unspecific) :test #'EQ)
:rename ;; rename to filename~
:error))))
(if-does-not-exist
(or (getf options :if-does-not-exist)
(SELECT direction ((:input nil) :error) ;here is where nil and :probe differ
(:output :create) (:otherwise nil))))
;; don't signal by default for a probe stream
(ERROR (NOT (MEMBER direction '(:probe :probe-directory) :test #'EQ))) ;nil,probe differ here (QFILE sets t)
estimated-length
;; New keys:
character-format ; :ascii / :ebcdic / (:ascii/:ebcdic :non-print/:telnet/:carriage-control)
(file-structure :file) ; :file / :record / :page
maximum-record-length ; must also give estimated-length to use this parm
;; Keys ignored:
preserve-dates deleted ;zwei uses these
temporary
;; Keys not allowed: ACCESS-ERROR, RAW, SUBMIT, FLAVOR, LINK-TO, ... ???
&aux phony-characters sign-extend-bytes (aborted t)
control-connection pseudo-direction ftp-character-format (file-format nil) truename file-did-exist
ftp-stream properties open-pathname)
(DECLARE (SPECIAL *ftpint-debug*))
(IGNORE preserve-dates deleted temporary)
;;; /////////////// DEBUG
(WHEN *ftpint-debug*
(PRINT
(FORMAT () "Open ~A Direction ~A If-exists ~A If-does-not-exist ~A"
pathname direction if-exists if-does-not-exist)))
;;;///////////////
;; Just in case
(SETQ pathname (MERGE-PATHNAMES (TRANSLATED-PATHNAME pathname)))
;;-----------------------------------------------------------------------
;; ------ PARAMETER VALIDATION
;;-----------------------------------------------------------------------
(CCASE direction ;prompts user if not one of listed values
((:input :output) (SETQ pseudo-direction direction))
(:probe-directory (SETQ pseudo-direction ()))
((nil :probe) (SETQ pseudo-direction ()))
((:io :probe-link) (FERROR 'ftp-error "Option ':DIRECTION :~A' not supported by FTP" direction)))
(CCASE if-does-not-exist
(:create
(WHEN (EQ direction :input)
(FERROR 'ftp-error "Option ':IF-DOES-NOT-EXIST :Create' not legal for input using FTP")))
(:error
(WHEN (EQ direction :output)
(FERROR 'ftp-error "Option ':IF-DOES-NOT-EXIST :Error' not legal for output using FTP")))
(nil)) ;legal option
(WHEN (AND if-exists (EQ direction :input))
(FERROR 'ftp-error "Option ':IF-EXISTS' not legal for input using FTP"))
(CCASE if-exists
((:rename :rename-and-delete) ;zmacs uses on replace of existing file
(SETQ if-exists :rename))
(:append
(WHEN (NEQ direction :output)
(FERROR 'ftp-error "Option ':IF-EXISTS :append' legal only for output"))
(SETQ pseudo-direction :append))
(:supersede (SETQ if-exists :truncate))
((:overwrite :error :truncate :new-version nil))) ;other legal options
;; This is a QFILE routine used as-is
(WHEN element-type-p
(SETF (VALUES characters byte-size phony-characters sign-extend-bytes)
(decode-element-type element-type byte-size)))
(CCASE characters
(:default ;used by fs-utilities (e.g. dired)
(IF character-format
;; THEN assume characters if character-format specified
(SETQ characters t)
;; ELSE check file type
(SETQ characters
(NOT
(MEMBER (SEND pathname :canonical-type) *copy-file-known-binary-types* :test
#'EQUAL)))))
((t nil)))
;;-----------------------------------------------------------------------
;; ----- FTP INTERACTION
;;-----------------------------------------------------------------------
(ip:with-stream-whostate
"Open"
(UNWIND-PROTECT ;make sure connection gets closed
(file-operation-retry
;; Move this up here in case byte-size property is returned
(UNLESS (EQ direction :probe-directory)
;; truename may be returned as a condition object
(MULTIPLE-VALUE-SETQ (truename file-did-exist properties)
(derive-truename pathname pseudo-direction if-exists if-does-not-exist error)))
(WHEN (EQ byte-size :default)
(SETQ byte-size (OR (GETF properties :byte-size)
(IF characters
8
16))))
(IF character-format
;; THEN
(PROGN
(IF (NOT characters)
(FERROR 'ftp-error "Option ':CHARACTER-FORMAT ~A' not valid for binary file" character-format))
(COND ((CONSP character-format)
(SETQ file-format (SECOND character-format))
(SETQ ftp-character-format (CAR character-format)))
(t (SETQ ftp-character-format character-format)))
(CCASE ftp-character-format ; (changed above)
((:ascii :ebcdic))
(nil (SETQ ftp-character-format :ascii)))
(ccase file-format
((:non-print :telnet :carriage-control))
(nil (SETQ file-format :non-print))))
;; ELSE
(IF characters
(PROGN
;; then
(SETQ ftp-character-format :ascii)
(SETQ file-format :non-print))
;; else
(SETQ ftp-character-format
(COND
((EQL byte-size 16)
(IF (ftp-omit-byte-size pathname)
:image
:byte-size))
((EQL byte-size 8) :image)
(:otherwise (FERROR 'ftp-error "Byte sizes other than 8 and 16 are not supported")))))) ;; end if
(WHEN (AND characters (NEQ byte-size 8))
(FERROR 'ftp-error "Byte sizes other than 8 are not supported for character files"))
(CCASE file-structure ;verify legal values
((:file :record :page)))
(WHEN maximum-record-length
(UNLESS estimated-length
(FERROR 'ftp-error
"MAXIMUM-RECORD-LENGTH not allowed unless ESTIMATED-LENGTH is also specified")))
;; Establish the connection (do after truename derivation, can re-use connection)
(UNLESS control-connection
(SETQ control-connection (reserve-ftp-connection (SEND pathname :host)))) ;error will be signalled
(IF (EQ direction :probe-directory)
;; then
;; special case probe-directory: list it to see if its there and then set truename to be just directory part
;; (This is a lot of work but I don't see how else to do it; It also doesn't guarantee anything if FTP Server
;; returns empty list for a non-existent directory)
(UNWIND-PROTECT
(UNLESS
(ftp-unfavorable
(ip:with-stream-whostate
"File data connection"
(SEND control-connection :open
(dir-pathstring-for-ftp
(SEND pathname :new-pathname :name :wild :type :wild :version :wild))
:nlist)))
(SETQ file-did-exist t)
(SETQ truename (SEND pathname :new-pathname :name () :type () :version ())))
(SEND control-connection :close :abort))
;; else
(PROGN
(IF (EQ direction :output)
(SETQ open-pathname truename) ;need for bumped version number
(SETQ open-pathname pathname)) ;don't trust our truename derivation unless necessary
;; ////////// DEBUG
(WHEN *ftpint-debug*
(PRINT (FORMAT () "Truename = ~A; File-did-exist = ~A" truename file-did-exist)))
;; //////////
;; Do some behind-the-scene manipulations (since FTP doesn't handle these options)
(WHEN file-did-exist
(SELECT if-exists
(:truncate (SEND control-connection :delete (pathstring-for-ftp pathname)))
(:rename
(LET ((bp (bastardize-filename pathname)))
;; If we can't bump version number, delete old backup file (if exists)
(WHEN (NEQ (SEND bp :version) :newest)
(SEND control-connection :delete (pathstring-for-ftp bp))) ;ignore error
(WHEN (ftp-unfavorable
(SEND control-connection :rename (pathstring-for-ftp truename)
(pathstring-for-ftp bp)))
(warn "Unable to rename ~A to ~A before opening" pathname bp))
))))))
;;-----------------------------------------------------------------------
;; ----- STREAM CONSTRUCTION
;;-----------------------------------------------------------------------
;; issue commands to ftp (control-connection), stopping if an error is encountered
(LET ((ip:*tcp-stream-instantiator*
;; ip:make-stream will use this to instantiate the data-connection
#'(lambda (&optional connection timeout input-buffer-size number-of-input-buffers &aux property-list)
;; do the best we can
(SETF property-list
(NCONC
(LIST :truename truename :byte-size byte-size
;;overrides dir-list byte-size in case this is different
;;:length 0 ;set this to 0 even if we know :length-in-bytes (this is the remote length
;and due to ascii-translation it can be off (see :who-line-information)
;;The above is correct for Character file, but doesn't
;;apply to binary streams since there is no ascii-translation
:length (if characters
0
(if (and (= 16. byte-size)
(member (type-of truename)
'(unix-ucb-pathname unix-pathname MSDOS-PATHNAME)))
(let ((l-i-b (getf properties :length-in-bytes 0)))
(if (and l-i-b (= l-i-b 0))
0
(setf (getf properties :length-in-bytes 0)
(/ (getf properties :length-in-bytes 0) 2))
(getf properties :length-in-bytes 0)))
(getf properties :length-in-bytes 0)))
:characters characters
;; These are new
:character-format ftp-character-format
:file-format file-format
:file-structure file-structure
;; don't set qfaslp
)
(IF (EQ direction :output)
(PROGN
(SEND pathname :set-property-list ())
())
properties))) ;include any we know from directory list (unless new file)
(CASE direction
(:input
(MAKE-INSTANCE
(ftp-stream-flavor-type direction byte-size characters phony-characters sign-extend-bytes)
:control-connection control-connection :property-list property-list
:host (SEND pathname :host) :pathname pathname
:connection connection :timeout timeout
:input-buffer-size input-buffer-size :number-of-input-buffers number-of-input-buffers))
(:output
(MAKE-INSTANCE
(ftp-stream-flavor-type direction byte-size characters phony-characters sign-extend-bytes)
:control-connection control-connection :property-list property-list
:host (SEND pathname :host) :pathname pathname
:connection connection :timeout timeout))
(otherwise
(MAKE-INSTANCE
(ftp-stream-flavor-type direction byte-size characters phony-characters sign-extend-bytes)
:control-connection control-connection :property-list property-list
:host (SEND pathname :host) :pathname pathname
:connection connection :timeout timeout
;; workaround Unix bug, allow one byte of file to be sent (holdover from Rel 1.0)
:input-buffer-size 1 :number-of-input-buffers 1))))))
(SETF ftp-stream
(BLOCK stream-construction
;; Check existence if user indicated that should be an error
(WHEN (AND (EQ if-exists :error) file-did-exist)
(SEND control-connection :set-reply-code ())
(RETURN-FROM stream-construction
(MAKE-CONDITION 'file-already-exists "Open of ~A failed because file already exists"
truename :open)))
;; Rel 1.0 commented out this and opened probe stream for input (actually when direction
;; was :probe-directory we did return-from stream construction here). We now return-from at this
;; point for all probe streams, to allow (probe-file (send pathname :directory-pathname-as-file)) to
;; work over FTP as well as Chaos
(WHEN (NOT pseudo-direction)
(COND ((NOT file-did-exist)
;; here the truename is a condition object
(SEND control-connection :set-reply-code nil)
(RETURN-FROM stream-construction truename))
(t (RETURN-FROM stream-construction (FUNCALL ip:*tcp-stream-instantiator*)))))
;; truename is a condition object, return it
(WHEN (ERRORP truename)
(SEND control-connection :set-reply-code nil)
(RETURN-FROM stream-construction truename))
;; Describe file to be opened to FTP
;; Don't do some of these (try to speed up the open)
(COMMENT (ftp-unfavorable (SEND control-connection :mode :stream)))
(WHEN (AND (NEQ file-structure :file)
(ftp-unfavorable (SEND control-connection :structure file-structure)))
(RETURN-FROM stream-construction nil))
(WHEN (ftp-unfavorable
(COND
(characters
(IF (EQ file-format :non-print)
(IF (EQ ftp-character-format :ascii)
t ;do nothing - this is the default
;; else send only character format (non-print is the default and Apollo croaks on it)
(SEND control-connection :type ftp-character-format))
;; else
(SEND control-connection :type ftp-character-format file-format)))
((EQ ftp-character-format :byte-size)
(SEND control-connection :type :byte-size byte-size))
(:otherwise (SEND control-connection :type :image))))
(RETURN-FROM stream-construction nil))
(WHEN (AND estimated-length
(ftp-unfavorable (SEND control-connection :allocate
estimated-length maximum-record-length)))
(RETURN-FROM stream-construction nil))
;; Do the open (use truename for bumped version)
;; Go ahead and always use the truename. Even if truename derivation didn't work
;; real well, at least we won't be lying about the truename of the stream. Also probe of
;; a directory on the Vax doesn't work without a version number
(ip:with-stream-whostate
"File data connection"
(LOOP
(SEND control-connection :open (pathstring-for-ftp truename) pseudo-direction)
;; workaround a Unix 425 bug which seems to go away on the second open attempt
(UNLESS (AND (EQ 425 (SEND control-connection :reply-code))
(EQ :bsd4.2 (SEND *ftp-service* :get-ftp-implementation-type (PATHNAME-HOST pathname)))
(SEARCH "Can't create data socket" (SEND control-connection :reply-string))
(SEARCH "Address already in use" (SEND control-connection :reply-string)))
(RETURN-FROM stream-construction
(UNLESS (ftp-unfavorable (SEND control-connection :reply-code))
;; the ftp data-connection is actually an instantiated ftp-stream
(SEND control-connection :data-connection))))))))
) ;end let ip:*tcp-stream-instantiator*
;; NOTE: streams opened with direction nil or :probe both return an error condition if :if-does-not-exist is
;; :error or nil otherwise. The difference is in the default for the :if-does-not-exist parm (see header).
(COND ((ftp-unfavorable (SEND control-connection :reply-code))
(COND ((NOT (OR pseudo-direction (EQ if-does-not-exist :error)))
(SETF ftp-stream nil)) ;; sometimes return nil for a probe-stream
(t
(SETF ftp-stream
(COND ((TYPEP ftp-stream 'condition) ftp-stream)
((AND (EQ pseudo-direction :input)
(OR (EQL 450 (SEND control-connection :reply-code))
(EQL 550 (SEND control-connection :reply-code))))
(LET ((reply-string (SEND control-connection :reply-string))
directory-list)
(free-ftp-connection (PROG1 control-connection (SETF control-connection nil))
nil :abort-data)
(COND ((OR (SEARCH "ermission" reply-string) (SEARCH "ERMISSION" reply-string)
(SEARCH "rivelege" reply-string) (SEARCH "RIVELEGE" reply-string))
(MAKE-CONDITION 'incorrect-access-to-file reply-string pathname :open))
(t
;; directory-list will supply the directory-not-found condition object
(SETF directory-list (SEND *ftp-service* :directory-list
:ftp truename '(:noerror)))
(IF (ERRORP directory-list)
directory-list
(MAKE-CONDITION 'fs:file-not-found "File not found for ~a"
truename :ftp-open))))))
((AND (EQ pseudo-direction :output)
(OR (EQL 450 (SEND control-connection :reply-code))
(EQL 553 (SEND control-connection :reply-code))
;; Unix violates spec by returning 550 on STOR, workaround it
(EQL 550 (SEND control-connection :reply-code))))
(LET ((reply-string (SEND control-connection :reply-string))
directory-list)
(free-ftp-connection (PROG1 control-connection (SETF control-connection nil))
nil :abort-data)
(COND ((OR (SEARCH "ermission" reply-string) (SEARCH "ERMISSION" reply-string)
(SEARCH "rivelege" reply-string) (SEARCH "RIVELEGE" reply-string))
(MAKE-CONDITION 'incorrect-access-to-file reply-string pathname :open))
(t
;; directory-list will supply the directory-not-found condition object
(SETF directory-list (SEND *ftp-service* :directory-list
:ftp truename '(:noerror)))
(IF (ERRORP directory-list)
directory-list
(MAKE-CONDITION 'ftp-open-error reply-string self :open))))))
(t (MAKE-CONDITION 'ftp-open-error
(SEND control-connection :reply-string) self :open))))
(WHEN error (SIGNAL-CONDITION ftp-stream)))))
(t
(IF pseudo-direction
(SEND control-connection :set-in-use ftp-stream) ;nice for display/debug
(SEND ftp-stream :close))
(SETF aborted nil)
)) ; end cond
) ; end file-operation-retry
(WHEN aborted
(IF (AND ftp-stream (TYPEP ftp-stream 'ftp-data-stream-mixin))
(SEND ftp-stream :close :abort)
(WHEN control-connection (free-ftp-connection control-connection nil :abort-data)))))) ; end unwind-protect
;; /////// DEBUG
(WHEN *ftpint-debug*
(PRINT ftp-stream))
;; ////////
ftp-stream ;return value
)nagase@dsg.csc.ti.com (N Nagase) (12/02/89)
RE: Has anyone modified ZMACS to keep "backup" (~) versions of files on UNIX systems (like gnuemacs does)? Believe it or not, code exists to do this in the current Explorer code, but it is in the Explorer Mail System. When you have your mail "BABYL" file on a UNIX type of file system, it will create a backup file "babyl~" before it saves the current mail buffer. It's in "sys:mail-reader;file.lisp", the function name is "WRITE-MAIL-FILE- BUFFER". It deletes the existing backup file an rename the current file to to the backup filel name. So, you will not lose the latest version; you may lose the backup version. I believe this code can be used in the general save file function without much modification. Regards, Nobi Nagase, Ticare