Rice@SUMEX-AIM.STANFORD.EDU (James Rice) (12/05/89)
;;; -*- Mode:COMMON-LISP; Package:FS; Base:10.; Patch-File: t -*-
;;; RESTRICTED RIGHTS LEGEND
;;;Use, duplication, or disclosure by the Government is subject to
;;;restrictions as set forth in subdivision (c)(1)(ii) of the Rights in
;;;Technical Data and Computer Software clause at 52.227-7013.
;;;
;;; TEXAS INSTRUMENTS INCORPORATED.
;;; P.O. BOX 2909
;;; AUSTIN, TEXAS 78769
;;; MS 2151
;;;
;;; Copyright (C) 1985- 1989 Texas Instruments Incorporated. All rights reserved.
;;; ** (c) Copyright 1980 Massachusetts Institute of Technology **
;;; The following code was written by James rice, except where
;;; code is marked by TI Code comments, to implement faked
;;; version numbers on hosts that don't understand version
;;; numbers, e.g. unix.
;;; The GNU convention of version numbers is used. Thus, all
;;; files which are not the :Newest have a version denoted by
;;; name.type.~nn~, where "nn" is a decimal number.
;;; This behaviour is encapsulated in the mixin called
;;; GNU-Version-Number-Mixin and is used to make a GNU version
;;; of unix pathnames called GNU-Ucb-Pathname or GNU-unix-pathname
;;; and mac pathnames called GNU-Mac-Pathname.
;;; You can convert to using this method by setting the
;;; pathname-flavor namespace attribute for the relevant
;;; hosts. You can change temporarily to get the GNU
;;; behaviour with the use of the functions
;;; Convert-Host-To-GNU-Pathnames and
;;; Unconvert-Host-To-GNU-Pathnames.
(defun GNUify-parse-table (table new-name-type-version-parse-function)
"Convert an existing pathname parse table into a GNU one that uses
new-name-type-version-parse-function as the function to parse the
name/type-version spec.
"
`(,(first table)
(,(first (second table))
,(second (second table))
,(third (second table))
,new-name-type-version-parse-function
,@(nthcdr 4 (second table))
)
,@(rest (rest table))
)
)
clos:
(defgeneric fs:pathname-parse-table-for (pathname)
(:Documentation "Given a pathname, returns the pathname parsing table for that
type of pathname.")
)
(defflavor GNU-version-number-mixin
()
()
(:Required-Flavors pathname)
:abstract-flavor
(:Documentation :Mixin "Adds GNU emacs type version numbers to pathnames
that don't understand versions.")
)
(defun GNU-parse-version-component (string ignore &optional ignore)
"Parses a GNU version specifier."
(cond
((zerop (length string)) nil)
((= (length string) 1.)
(let ((chr (aref string 0.)))
(cond
((char= chr #\*) :wild)
((char= chr #\) nil)
((char= chr #\) :unspecific)
(t string))))
(t (let ((result (catch-error (let ((*read-base* 10.))
(read-from-string string)
)
nil
)
)
)
(if (numberp result)
result
nil ;;; !!! Warning maybe we should give an error here.
;;; !!! but a nil here will cause punting to old type
;;; !!!unix pathname parsing in :parse-namestring.
)
)
)
)
)
(defun GNU-parse-version (string self &optional junk-allowed)
"Parses a GNU version specifier taking max length into account."
(let ((result
(unix-name-validation
(GNU-parse-version-component string self junk-allowed)
(send self :version-length) junk-allowed
)
)
)
(typecase result
(string (read-from-string result))
(otherwise result)
)
)
)
clos:
(defgeneric fs:max-pathname-length (pathname)
(:Documentation
"Returns the maximum printed length of a pathname of this type."
)
)
(defmethod (GNU-version-number-mixin :version-length) ()
;;; The version equivalent of :type-length and :name-length.
(- (max-pathname-length self)
3 ;;; allow for the .~~ in e.g. .~42~
(length (get-filename self name type))
)
)
(defun GNU-version-string (version)
"The printed representation of a GNU version specifier."
(case version
(:unspecific "")
(:Wild "*")
(:Newest "")
(otherwise (if (numberp version)
(let ((*nopoint t)) (format nil ".~~~D~~" version))
"" ;;; We don't know what it is. This may be a cop-out.
)
)
)
)
clos:
(defgeneric fs:get-directory-string (pathname)
(:Documentation "Gets the directory string for a pathname.")
)
clos:
(defgeneric fs:get-filename (pathname name type)
(:Documentation "Gets the filename string for a pathname.")
)
clos:
(defgeneric fs:get-device-string (pathname)
(:Documentation "Gets the device string for a pathname.")
)
(defmethod (GNU-version-number-mixin :string-for-host) ()
(format () "~A~@[~A~]~A~A"
(get-device-string self)
(Get-Directory-String self)
(get-filename self name type)
(GNU-version-string version)
)
)
(defmethod (GNU-version-number-mixin :string-for-editor) ()
(format () "~A~A ~A~@[~A ~]~A:"
(Get-Filename self name type)
(GNU-version-string version)
(get-device-string self)
(Get-Directory-String self)
(send host :name)
)
)
(defwhopper (GNU-version-number-mixin :string-for-printing) (&rest args)
; (setq string-for-printing nil)
(let ((result (lexpr-continue-whopper args))
(version-string (GNU-version-string version))
)
(if (string= result version-string
:Start1 (- (length result) (length version-string))
:Start2 0
)
result
(setq string-for-printing
(string-append result (GNU-version-string version))
)
)
)
string-for-printing
)
(defwhopper (GNU-version-number-mixin :short-string-for-printing) (&rest args)
; (setq short-string-for-printing nil)
(let ((result (lexpr-continue-whopper args))
(version-string (GNU-version-string version))
)
(if (string= result version-string
:Start1 (- (length result) (length version-string))
:Start2 0
)
result
(setq short-string-for-printing
(string-append result (GNU-version-string version))
)
)
)
)
(defmethod (GNU-version-number-mixin :string-for-dired) ()
(format nil "~A~A" (Get-Filename self name type) (GNU-version-string version))
)
(defmethod (GNU-version-number-mixin :parse-version-spec) (spec)
(cond
((stringp spec) (GNU-parse-version spec t))
((or (fixnump spec) (member spec '(nil :unspecific :wild) :test #'eq)) spec)
((eq spec :newest) :unspecific)
(t :unspecific)
)
)
(defwhopper (GNU-version-number-mixin :pathname-match) (pathname &rest args)
;;; Use the eisting matching code for everything other than versions. If
;;; all else matches then check versions.
(and (lexpr-continue-whopper pathname args)
(multiple-value-bind (w* w1) (send self :internal-wild-characters)
(pathname-component-match version (pathname-version pathname) w* w1)
)
)
)
clos:
(defgeneric fs:GNU-Pathname-Flavor-For (flavor-name)
(:Documentation "Given the name of a pathname flavor, returns the GNUified
version of that pathname type."
)
)
(defun flush-pathnames-of-flavor-for-host (flavor host)
"Removes all existing pathnames of a given flavor for host. If flavor is :any
then it will flush all pathnames for that host.
"
(let ((host (net:parse-host host)))
(maphash #'(lambda (key path)
(if (and (or (equal flavor :Any) (typep path flavor))
(equal (pathname-host path) host)
)
(remhash key fs:*pathname-hash-table*)
nil
)
)
fs:*pathname-hash-table*
)
)
)
(defun convert-host-to-GNU-pathnames (host)
"Given a host converts it temporarily so that it will use GNU type pathnames.
If you want this to be a permanent change you should change your namespace
for the relevant hosts.
"
(let ((host (net:parse-host host)))
(let ((flavor
(send host :Pathname-Flavor-Internal (send host :system-type))
)
)
(send host :Set-Pathname-Flavor (GNU-pathname-flavor-for flavor))
(Flush-Pathnames-Of-Flavor-For-Host flavor host)
)
(if (send host :Sample-Pathname)
(set-in-instance host 'net:sample-pathname
(fs:make-pathname :Host host)
)
nil
)
host
)
)
(defun unconvert-host-to-GNU-pathnames (host)
"Given a host that has probably been converted to use GNU type pathnames,
converts it back to use the default pathname flavor.
"
(let ((host (net:parse-host host)))
(let ((flavor
(send host :Pathname-Flavor-Internal (send host :system-type))
)
)
(send host :Set-Pathname-Flavor flavor)
(Flush-Pathnames-Of-Flavor-For-Host (GNU-pathname-flavor-for flavor)
host
)
)
(if (send host :Sample-Pathname)
(set-in-instance host 'net:sample-pathname
(fs:make-pathname :Host host)
)
nil
)
host
)
)
;;; Delete this function so that we can make it specialisable.
(fmakunbound 'bastardize-filename)
clos:
(defgeneric fs:bastardize-filename (pathname)
(:Documentation "Given a pathname, returns a new pathname that will be used
to rename the file named by this pathname to in order to generate a new version
for the new file being opened.
")
)
;;; This is the old version from sys:ip;ftp-stream.lisp
;;; TI Code.
(defmethod bastardize-filename ((pathobj pathname))
;; 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.
(let (filename sl)
(SETQ filename (SEND pathobj :name))
(WHEN (> (SETQ sl (LENGTH filename)) 2)
(SETQ filename (SUBSEQ filename 0 (MAX 2 (- sl 4)))))
;; for file systems with versioning, use :newest
(IF (EQ (SEND pathobj :version) :unspecific)
(SEND pathobj :new-pathname :name (STRING-APPEND filename "ZBAK"
))
(SEND pathobj :new-pathname :name (STRING-APPEND filename "ZBAK"
) :version :newest))))
(defmethod (GNU-version-number-mixin :find-next-to-newest-version-number) ()
"Finds the version number of the latest version that has a version number
of the GNU variety (.~nn~). Thus, if there is already a foo.lisp,
a foo.lisp.~1~ and a foo.lisp.~4~, it will return 4.
Note: this method has to do a directory list of the host so could be rather
slow.
"
(if (numberp version)
version ;;; This operation is only really meaningful for :newest.
(let ((dir (condition-case ()
(rest (directory-list
(send self :New-Pathname
:type :Unspecific :version :Wild
)
)
)
;; Catch this condition because we get this error if there
;; are no files of the form name.type*
(directory-not-found-error nil)
)
)
)
(let ((versions
;; This may include :unspecific for #> at the front now.
(loop for (path) in dir
when
(and (equal (send path :name) (send self :name))
(equal (send path :type) (send self :type))
(not (equal :Unspecific (send path :Version)))
)
collect (pathname-version path)
)
)
)
; (print versions)
(case version
((:Newest :Unspecific nil :Wild)
;;; :wild is really an error but make this unbrittle.
(let ((found (if versions (apply #'max versions) nil)))
(case found
((:Unspecific nil) 0)
(otherwise found)
)
)
)
(otherwise 0) ;; Don't know what's happening
)
)
)
)
)
(defmethod (ftp-output-stream-mixin :maybe-restore-old-version) ()
;;; Called when we undinw protect on closing files. Let the pathname type
;;; handle this.
(ip:with-stream-whostate "Restore Last Version"
(send (send self :Pathname) :Maybe-Restore-Old-Version)
)
)
(defmethod (chaos:basic-stream :maybe-restore-old-version) ()
;;; Called when we undinw protect on closing files. Let the pathname type
;;; handle this.
(if (typep self 'si:output-stream)
(send (send self :Pathname) :Maybe-Restore-Old-Version)
nil
)
)
(defmethod (pathname :Maybe-Restore-Old-Version) ()
;;; most pathnames don't know how to deal with this.
nil
)
(defmethod (GNU-version-number-mixin :Maybe-Restore-Old-Version) ()
;;; Restore the old version of the file that we renamed when the file was
;;; opened.
(let ((old-version
(send self :find-next-to-newest-version-number)
)
)
(let ((old-file
(probe-file (send self :New-Version old-version))
)
)
(if old-file
(rename-file old-file self)
nil
)
)
)
)
(defmethod bastardize-filename ((pathobj GNU-version-number-mixin))
"For GNU pathnames we want 1 + the number of the most recent .~nn~ version."
(let ((new-version (+ 1 (send pathobj :find-next-to-newest-version-number))))
(send pathobj :New-Version new-version)
)
)
clos:
(defgeneric fs:Pathname-Type-Fakes-Version-Numbers (pathname)
(:Documentation
"A predicate which is true if the flavor of pathname in question fakes version
numbers, as opposed to the host itself understanding version numbers. For
example, GNU pathnames fake version numbers by using .~nn~ as a convention
to indicate all versions other than the :newest.
")
)
(defmethod pathname-type-fakes-version-numbers ((path pathname))
"Most pathnames don't fake version numbers, they either have them
or they don't.
"
nil
)
(defmethod pathname-type-fakes-version-numbers ((path GNU-version-number-mixin))
"GNU pathnames fake version numbers."
t
)
(defwrapper (file-data-stream-mixin :Close) ((abortp) . body)
`(progn ,@body
(if (and abortp (typep self 'si:output-stream))
(condition-case () (send self :Maybe-Restore-Old-Version)
(file-operation-failure nil)
)
nil
)
)
)
;;; TI Code modified to deal with renaming GNU type versions.
(DEFMETHOD (ftp-output-stream-mixin :around :close) (cont mt args &optional abortp)
"Close the stream by calling a method of ftp-control-connection. This stream is the data-connection of
an ftp-control-connection. Ftp-control-connection calls will recurse back through here with
ip:*ftp-data-connection-close* bound to true."
(DECLARE (SPECIAL ip:*ftp-data-connection-close*))
(ip:with-stream-whostate
"File Close"
(BLOCK nil
(COND
;; this is a data connection close coming back from the ftp-control-connection method
(ip:*ftp-data-connection-close*
(RETURN (AROUND-METHOD-CONTINUE cont mt args)))
((EQ file-status :closed) (RETURN file-status)))
;; drive the close through the control connection
;; Closing an open output channel. Finish sending the data.
(WHEN (EQ file-status :open) (SEND self :eof))
(SETQ file-status :closed)
(SEND (net:translated-host (PATHNAME-HOST pathname)) :deregister-stream self)
(UNWIND-PROTECT
(COND (abortp
(SEND control-connection :close :abort)
;; If aborting out of a file-writing operation before normal :CLOSE,
;; delete the incomplete file. Don't worry if it gets an error.
;; Dont use the delete method of stream (get into recursive calls to close, ...)
(LET ((reply-code (SEND control-connection :reply-code))
(reply-string (SEND control-connection :reply-string)))
(SEND control-connection :delete (pathstring-for-ftp pathname))
(send self :Maybe-Restore-Old-Version)
;; mask errors incurred by :delete
(SETF (SEND control-connection :reply-code) reply-code
(SEND control-connection :reply-string) reply-string)))
(t
(WHEN (OR signal-ftp-close-reply (ftp-unfavorable (SEND control-connection :close)))
(SEND tv:who-line-file-state-sheet :delete-stream self)
(SIGNAL
(MAKE-CONDITION 'ftp-error (SEND control-connection :reply-string) pathname :close)
:proceed-types ()))))
(UNLESS *close-data-connection-only* (free-ftp-connection control-connection)))
file-status)))
;;;---- FTP-OPEN
;;; TI Code modified to deal with GNU pathnames.
;;; modified from the modified version from Jamey Hicks <jamey@au-bon-pain.lcs.mit.edu>
(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 (not (eql byte-size 8))) ;; changed from neq by JPR to remove warning
(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)))
((:New-Version :Rename)
;;; Modified here by JPR to allow the bastardisation of
;;; files for :new-version if the pathname type
;;; fakes version numbers.
(if (or (eq :Rename if-exists)
(pathname-type-fakes-version-numbers pathname))
(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 (EQL 425 (SEND control-connection :reply-code)) ;; changed from eq by JPR to remove warning
(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
)
;===============================================================================
(defun maybe-rename-file-chaos (pathname if-exists)
(if (or (eq :Rename if-exists)
(and (eq :New-Version if-exists)
(Pathname-Type-Fakes-Version-Numbers pathname)
)
)
(let ((truename (send pathname :Truename nil)))
(if (typep truename 'pathname)
(let ((bp (bastardize-filename pathname)))
(if (not (catch-error
(progn (rename-file truename bp) t)
nil
)
)
(warn
"Unable to rename ~A to ~A before opening" pathname bp
)
t
)
)
nil
)
)
nil
)
)
(defun open-chaos (host pathname &rest options &key
(direction :input)
(characters t)
(error t)
(access-error (not error))
(element-type 'string-char element-type-p)
(if-exists
;; Modified here by JPR. Copied from FTP-OPEN
(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
(cond ((member direction
'(:probe :probe-link :probe-directory) :test #'eq) nil)
((and (eq direction :output)
(not (member if-exists '(:overwrite :truncate :append) :test #'eq)))
:create)
;; Note: if DIRECTION is NIL, this defaults to :ERROR
;; for compatibility with the past.
;; A Common-Lisp program would use :PROBE
;; and get NIL as the default for this.
;;; added by JPR. we need to create if we have
;;; already renamed the file.
((and (Pathname-Type-Fakes-Version-Numbers pathname)
(member if-exists '(:Rename :New-Version))
)
:Create
)
(t :error)))
temporary
deleted
raw
super-image
(byte-size :default)
preserve-dates
inhibit-links
submit
estimated-length
&allow-other-keys)
;; This call added by JPR
(maybe-rename-file-chaos pathname if-exists)
(flet ((body ()
(let (host-unit
data-conn
pkt
success
string
not-aborted
phony-characters
sign-extend-bytes
if-exists-p
direct-file-id
(*package* *system-package*)
(default-cons-area background-cons-area))
(ccase direction
((:input :output :probe-directory :probe-link))
(:io (setq direct-file-id (file-gensym "IO")) ; 09-02-87 DAB IO Support
)
((nil :probe)
(setf (getf options :direction) nil)
(setq direction ())))
(check-type if-exists
(member :error :new-version :rename :rename-and-delete :overwrite :append :truncate
:supersede ()))
(check-type if-does-not-exist (member :error :create ()))
;; IF-EXISTS-P is T if we need to give the IF-EXISTS to the server.
(setq if-exists-p
(not
(member if-exists
(case (pathname-version pathname)
(:newest '(:new-version))
(:unspecific '(:new-version :supersede)))
:test #'eq)))
(when element-type-p
(setf (values characters byte-size phony-characters sign-extend-bytes)
(decode-element-type element-type byte-size))
(setf (getf options :characters) characters)
(setf (getf options :byte-size) byte-size))
(file-operation-retry
(condition-case-if access-error (error-object)
(progn
(if (member direction '(nil :probe-directory :probe-link) :test #'eq)
;;PROBE mode implies no need for data connection
(setq host-unit (send *qfile-service* :get-host-unit host))
(multiple-value-setq (data-conn host-unit)
(send *qfile-service* :get-data-connection host direction))))
(remote-network-error error-object)
(:no-error
(unwind-protect
(progn
(multiple-value-setq (pkt success string)
;; If the destination is another Explorer.
(if (or (typep pathname 'new-lm-parsing-mixin) ;09-14-88 DAB
(typep pathname 'mac-pathname)
(eq (send host :system-type) :lispm))
(send host-unit :command ()
(case direction
(:input (data-input-handle data-conn))
(:output (data-output-handle data-conn))
(:io "")) ; 09-02-87 DAB IO Support
()
"OPEN-FOR-LISPM "
#\Newline
(file-print-pathname pathname)
#\Newline
(let ((*print-base* 10)
(*nopoint t)
(*package* si:pkg-user-package)
(*print-length* nil)
(*readtable* si::common-lisp-readtable))
(when (and (eq direction :output)
(null if-exists))
(setq options (list* :if-exists :error options)))
(when (and (not if-exists-p)
(get-location-or-nil (locf options) :if-exists))
(setq options (copy-list options))
(remprop (locf options) :if-exists))
(when (null if-does-not-exist)
(setq options (list* :if-does-not-exist :error options)))
(when (eq direction :io) ; 09-02-87 DAB IO Support
(setq options (list* :direct-file-id direct-file-id options)))
(format nil "~S" options)))
(send host-unit :command ()
(case direction
(:input (data-input-handle data-conn))
(:output (data-output-handle data-conn)))
()
"OPEN "
(case direction
((nil) "PROBE")
(:probe-directory "PROBE-DIRECTORY")
(:probe-link "PROBE INHIBIT-LINKS")
(:input "READ")
(:output "WRITE"))
" "
(case characters
((nil) "BINARY")
(:default "DEFAULT")
(t "CHARACTER"))
(if (eq :CHAOS-COMMON (send host :send-if-handles :server-type)) ;;LSS
;no since sending this on a probe
(string-append
(if (and (eq direction :output) if-exists-p)
(string-append " IF-EXISTS "
(if (eq if-exists ())
:error
if-exists))
"")
(if (or if-exists-p
(neq if-does-not-exist
(case direction
((:input nil :probe-directory :probe-link) :error)
(:output :create))))
(if direction ;02-05-88 DAB
(string-append " IF-DOES-NOT-EXIST "
(if (eq if-does-not-exist ())
:error
if-does-not-exist))
"")
"")
)
"")
(if inhibit-links
" INHIBIT-LINKS"
"")
(format ()
"~:[ BYTE-SIZE ~D~;~*~]~:[~; TEMPORARY~]~:[~; DELETED~]~
~:[~; RAW~]~:[~; SUPER~]~:[~; PRESERVE-DATES~]~
~:[~; SUBMIT~]~@[ ESTIMATED-LENGTH ~D~]~%~A~%"
(eq byte-size :default) byte-size temporary deleted raw
super-image preserve-dates submit estimated-length
(file-print-pathname pathname)))))
(cond ((not success)
(setq not-aborted t)
(setq string (string-append string))
(and pkt (chaos:return-pkt pkt))
(or (null data-conn) (if (eq direction :io) ; 09-02-87 DAB IO Support
(progn (setf (data-stream data-conn :input) ())
(setf (data-stream data-conn :output) ()))
(setf (data-stream data-conn direction) ())))
(condition-case-if (not if-does-not-exist) ()
(condition-case-if (not if-exists) ()
(file-process-error-new string pathname () (not error) :open)
(file-already-exists nil))
(file-not-found nil)))
(t
(let ((properties
(read-file-property-list-string string "OPEN" pathname)))
(chaos:return-pkt pkt)
(and (eq characters :default)
(setq characters (getf properties :characters)))
(unless (or (eq byte-size :default) (getf properties :byte-size))
(setf (getf properties :byte-size) byte-size))
(when (eq direction :io) ; 09-02-87 DAB IO Support
(setf (getf properties :direct-file-id) direct-file-id))
;; *BJ* For *DAB*.
;; Check for case where a specific version number was specified
;; and :if-does-not-exist is :new-version. This will make sure that
;; the user will have the correct version number.
(if (and (eq if-exists :new-version)
(eq direction :output)
(integerp (pathname-version pathname)))
(unless (eq (pathname-version pathname)
(send (getf properties :truename) :version))
(setf pathname (send pathname :new-version :newest))))
(prog1
(make-instance
(case direction
(:input
(if characters
'file-input-character-stream
(cond
(sign-extend-bytes 'file-input-signed-binary-stream)
(phony-characters 'file-input-phony-character-stream)
(t 'file-input-binary-stream))))
(:output
(if characters
'file-output-character-stream
(if phony-characters
'file-output-phony-character-stream
'file-output-binary-stream)))
(:io ; 09-02-87 DAB IO Support
(if characters
'file-IO-character-stream
'file-IO-binary-stream))
(t 'file-probe-stream))
:host-unit host-unit :data-connection data-conn
:property-list
properties :pathname pathname)
(setq not-aborted t))))))
(unless (or not-aborted (null data-conn) (null (send host-unit :control-connection)))
;; Here if aborted out of it and server may have file open.
(condition-case ()
(progn
(and (eq direction :output)
(send host-unit :command () (data-output-handle data-conn) () "DELETE"))
(multiple-value-bind (nil close-success)
(send host-unit :command ()
(case direction
(:input (data-input-handle data-conn))
(:output (data-output-handle data-conn))
(:io direct-file-id)) ; 09-02-87 DAB IO Support
()
"CLOSE")
(when close-success
(case direction
(:input (read-until-synchronous-mark (data-connection data-conn)))
(:output
(chaos:send-pkt (data-connection data-conn) (chaos:get-pkt)
%file-synchronous-mark-opcode)))))
(if (eq direction :io) ; 09-02-87 DAB IO Support
(progn
(send host-unit :free-data-connection data-conn :input)
(send host-unit :free-data-connection data-conn :output))
(send host-unit :free-data-connection data-conn direction)))
(host-stopped-responding nil)))
) ;unwind
))))
)) ;flet JPR.
(condition-case-if
(Pathname-Type-Fakes-Version-Numbers pathname)
()
(body)
;; Try once more because sometimes we get faked out by file renaming.
(file-lookup-error
(apply 'Open-Chaos host pathname options)))))
;===============================================================================
;===============================================================================
;;; Actual pathname flavor implementations.
;-------------------------------------------------------------------------------
;
; Unix version.
;
;-------------------------------------------------------------------------------
(defvar GNU-unix-table
(GNUify-Parse-Table unix-table 'Unix-Parse-Name-Type-And-Version)
"Pathname parsing table for GNU unix pathnames."
)
;;; Modified TI Code.
;;; Modified from unix-parse-name-and-type by JPR.
(defun unix-parse-name-type-and-version
(string self &optional junk-allowed (look-for-version-p t))
;; look-for-versions-p arg added by JPR.
(cond
((or (not (stringp string)) (zerop (length string)))
(values nil (if *merge-unix-types* nil :unspecific)))
(t
(let ((period-position ;Find right most period position
(position #\. (the string (string string))
:from-end t :test #'char=))
typ nam ver non-period-position) ;; ver added by JPR.
(cond
((or (null period-position) (zerop period-position))
;No period or right most period is in position 0
(setq typ (if *merge-unix-types* nil :unspecific)
nam (unix-parse-name string self junk-allowed)))
((= (1+ period-position) (length string))
;Period is at right most position.
(setq typ (if *merge-unix-types* nil :unspecific)
nam (unix-parse-name (nsubstring string 0 (1+ period-position))
self junk-allowed)))
;======================================================================
;;; This clause added by JPR for GNU pathnames.
((and look-for-version-p
(char= #\~ (aref string (- (length (the string string)) 1)))
(< period-position (- (length (the string string)) 3))
(char= #\~ (aref string (+ period-position 1)))
(setq ver (GNU-parse-version
(subseq (the string string)
(+ 2 period-position)
(- (length (the string string)) 1))
self junk-allowed)))
(multiple-value-setq (nam typ)
(unix-parse-name-type-and-version
(subseq string 0 period-position) self junk-allowed nil)))
;======================================================================
(t
(setq non-period-position ;6.12.87 MBC
(position #\. (the string (string string))
:from-end t :test-not #'char= :end period-position))
(if non-period-position
; if there isn't another non-period character,
; type is NIL/:UNSPECIFIC
(setq typ (unix-parse-type
(nsubstring string (1+ period-position))
self junk-allowed)
nam (unix-parse-name
(nsubstring string 0 period-position)
self junk-allowed))
(setq typ (if *merge-unix-types* nil :unspecific)
nam (unix-parse-name string self junk-allowed)))))
(when (and (stringp nam) (stringp typ))
;;; together name, type and version are limited to the name-length...
;;; But we don't want to truncate either one too severely, so lets
;;; keep 9 letters minimum for name and type & version will always
;;; have a minimum of four letters. So... we're sometimes forced
;;; to truncate BOTH name and type, but the distribution is kind of
;;; arbitrary. 9.21.87
(setf nam (unix-name-validation
nam (max 9. (- (send self :name-length) (length typ) 1))))
(when (> (+ (length nam) (length typ)) (send self :name-length))
(setf typ (unix-name-validation
typ (- (send self :name-length) (length nam) 1)))))
;;; Version check added by JPR.
(values nam typ (if (numberp ver) ver :unspecific))))))
(defflavor GNU-Unix-Pathname-Internal
()
(GNU-Version-Number-Mixin)
(:Required-Flavors pathname)
(:Documentation "A common superclass for ucb and generic unix pathnames.")
:Abstract-Flavor
)
(defmethod Pathname-Parse-Table-For ((me GNU-Unix-Pathname-Internal))
GNU-Unix-Table
)
;;; Modified from TI code. [(new-unix-pathname-mixin :parse-namestring)]
(defmethod (GNU-Unix-Pathname-Internal :parse-namestring)
(ignore namestring &optional (start 0) end)
(multiple-value-bind (dir nam typ ver len)
(lm-parse-namestring namestring self (Pathname-Parse-Table-For self)
start end
)
(when (and (eq :apollo (net:get-host-attribute host :machine-type)) ;6.16.87
(> (or end (length namestring)) (+ 3 start))
(char= #\/ (char namestring start))
(char= #\/ (char namestring (1+ start))))
(typecase dir
(keyword (setf dir (list (concatenate 'string "/" nam))
nam nil))
(cons (setf (first dir) (concatenate 'string "/" (first dir))))
(string (setf dir (concatenate 'string "/" dir)))))
(values :unspecific dir nam typ ver len )))
(defmethod Get-Directory-String ((me GNU-Unix-Pathname-Internal))
(unix-directory-string)
)
(defmethod Get-Filename ((me GNU-Unix-Pathname-Internal) name type)
(unix-filename name type)
)
(defmethod Get-device-string ((me GNU-Unix-Pathname-Internal))
""
)
;-------------------------------------------------------------------------------
(defflavor GNU-ucb-pathname
()
(GNU-Unix-Pathname-Internal unix-ucb-pathname)
(:Documentation "Pathnames like UCB pathnames only they have .~n~ version
numbers.")
)
(defmethod max-pathname-length ((me GNU-ucb-pathname))
255.
)
(defmethod GNU-pathname-flavor-for ((flavor (eql 'unix-ucb-pathname)))
'GNU-ucb-pathname
)
;-------------------------------------------------------------------------------
;
; Generic Unix variant.
;
;-------------------------------------------------------------------------------
(defflavor GNU-Unix-Pathname
()
(GNU-Unix-Pathname-Internal unix-pathname)
(:Documentation "Pathnames like unix pathnames only they have .~n~ version
numbers.")
)
(defmethod max-pathname-length ((me GNU-ucb-pathname))
14. ;[!]
)
(defmethod GNU-pathname-flavor-for ((flavor (eql 'unix-pathname)))
'GNU-unix-pathname
)
;-------------------------------------------------------------------------------
;
; Mac variant.
;
;-------------------------------------------------------------------------------
(defvar GNU-mac-table
(GNUify-Parse-Table mac-table 'Mac-Parse-Name-Type-And-Version)
"Pathname parsing table for GNU unix pathnames."
)
;;; Modified TI Code.
;;; Modified from mac-parse-name-and-type by JPR.
(defun Mac-Parse-Name-Type-And-Version
(string self &optional junk-allowed (look-for-version-p t))
;; look-for-versions-p arg added by JPR.
(cond
((or (not (stringp string)) (zerop (length string)))
(values nil (if *merge-mac-types* nil :unspecific)))
;NIL case still use global flag 1.23.87 MBC
(t
(let ((period-position ;Find right most period position
(position #\. (the string (string string))
:from-end t :test #'char=))
typ nam ver non-period-position) ;; ver added by JPR.
(cond
((or (null period-position) (zerop period-position))
;No period or right most period is in position 0
(setq typ (if *merge-mac-types* nil :unspecific)
nam (mac-parse-name string self junk-allowed :unspecific)))
;05-23-88 DAB
((= (1+ period-position) (length string))
;Period is at right most position.
(setq typ (if *merge-mac-types* nil :unspecific)
nam (mac-parse-name (nsubstring string 0 (1+ period-position))
self junk-allowed :unspecific)))
;======================================================================
;;; This clause added by JPR for GNU pathnames.
((and look-for-version-p
(char= #\~ (aref string (- (length (the string string)) 1)))
(< period-position (- (length (the string string)) 3))
(char= #\~ (aref string (+ period-position 1)))
(setq ver (GNU-parse-version
(subseq (the string string)
(+ 2 period-position)
(- (length (the string string)) 1))
self junk-allowed)))
(multiple-value-setq (nam typ)
(unix-parse-name-type-and-version
(subseq string 0 period-position) self junk-allowed nil)))
;======================================================================
;05-23-88 DAB
(t
(setq non-period-position ;6.12.87 MBC
(position #\. (the string (string string))
:from-end t :test-not #'char= :end period-position))
(if non-period-position
;if there isn't another non-period character,
;type is NIL/:UNSPECIFIC
(setq typ (mac-parse-type
(nsubstring string (1+ period-position))
self junk-allowed :unspecific)
;05-23-88 DAB
nam (mac-parse-name
(nsubstring string 0 period-position)
self junk-allowed :unspecific))
(setq typ (if *merge-mac-types* nil :unspecific)
nam (mac-parse-name string self junk-allowed
:unspecific)))));05-23-88 DAB
(when (and (stringp nam) (stringp typ))
;;; together name and type are limited to the name-length... But
;;; we don't want to truncate either one too severely, so lets
;;; keep 9 letters minimum for name and type will always have a
;;; minimum of four letters. So... we're sometimes forced to
;;; truncate BOTH name and type, but the distribution is kind of
;;; arbitrary. 9.21.87
(setf nam (mac-name-validation ;05-23-88 DAB
nam
(max 9.
(- (send self :name-length :unspecific)
(length typ) 1))))
(when (> (+ (length nam) (length typ) 1)
(send self :name-length :unspecific))
(setf typ (mac-name-validation typ (send self :type-length nam)))))
;;; Version check added by JPR.
(values nam typ (if (numberp ver) ver :unspecific))))))
(defflavor GNU-mac-pathname
()
(GNU-version-number-mixin mac-pathname)
(:Documentation "Pathnames like unix pathnames only they have .~n~ version
numbers.")
)
(defmethod Pathname-Parse-Table-For ((me GNU-Mac-Pathname))
GNU-Mac-Table
)
(defmethod max-pathname-length ((me GNU-Mac-Pathname))
31.
)
(defmethod (GNU-mac-pathname :parse-namestring)
(ignore namestring &optional (start 0) end)
(let ((fs:*defaults-are-per-host* t) ;03-17-88 DAB
(sys:char-upcase-vector fs:mac-char-upcase-vector)) ;; Tung - 4/14/88
;;;I removed parse-pathname-find-colon on 06-16-88 DAB It was causing
;;;more trouble than it was worth.
(multiple-value-bind (dev dir nam typ ver len)
(lm-parse-namestring namestring self (Pathname-Parse-Table-For self)
start end
)
(values dev dir nam typ ver len)))) ;1.27.88 MBC
(defmethod GNU-pathname-flavor-for ((flavor (eql 'mac-pathname)))
'GNU-Mac-Pathname
)
(defmethod Get-Directory-String ((me GNU-Mac-Pathname))
(mac-directory-string)
)
(defmethod Get-Filename ((me GNU-Mac-Pathname) name type)
(mac-filename name type)
)
(defmethod Get-device-string ((me GNU-Mac-Pathname))
(clos:with-slots (device) me
(format () "~@[~A:~]" ;2.02.88 MBC 2.04.88
(if (member device '(:unspecific nil) :test #'eq) nil device)
;1.27.88 MBC
)
)
)
;;; TI Code. This is a modified version of (MAC-PATHNAME-MIXIN :NEW-PATHNAME)
;;; The only changes are marked with JPR.
(Defmethod (GNU-Mac-Pathname :NEW-PATHNAME) (&REST OPTIONS &KEY &OPTIONAL STARTING-PATHNAME &ALLOW-OTHER-KEYS)
(LET ((fs:*defaults-are-per-host* t)
(new-device (OR (GETF options :device) (GETF options :raw-device))) ;05-13-88 DAB
(new-directory (OR (GETF options :directory) (GETF options :raw-directory))) ;05-13-88 DAB
(new-name (OR (GETF options :name) (GETF options :raw-name)))
(new-type (OR (GETF options :type) (GETF options :raw-type)
(and (GETF options :canonical-type) ;truncation should be based on the canonical type 06-08-88 DAB
(DECODE-CANONICAL-TYPE (GETF options :canonical-type)
(SEND self :SYSTEM-TYPE)))
))) ;3.21.88 MBC for :TRANSLATED-PATHNAME length problems.
(when (STRINGP new-device) ;05-13-88 DAB
(SETF new-device (MAC-NAME-VALIDATION new-device (send self :device-length))))
(when new-directory ;05-13-88 DAB
(setf new-directory
(cond ((MEMBER new-directory '(:root :unspecific :wild)) new-directory)
((or (stringp new-directory)
(symbolp new-directory))
(setq new-directory (string new-directory))
(do ((start 0)
(end 0)
(new-list()))
((null end) (reverse (remove (string "") new-list :test #'string-equal)))
(setq end (position #\: new-directory :test #'char= :start start))
(push (MAC-NAME-VALIDATION
(nsubstring new-directory start end)
(send self :directory-length)) new-list)
(when end (setf start (1+ end)))))
((consp new-directory) ;handle case '("dir1" "dir2" ...)
(if (and (eq (car new-directory) :root) (eql (length new-directory) 1)) ;case '(:root) 06-20-88 DAB ; changed eq to EQL. JPR.
:root
(let ((new-list ()))
(dolist (old-dir new-directory (reverse new-list))
(case old-dir ;06-20-88 DAB
(:root ()) ;case '(:root "abc" ...)
((:unspecific :wild) (push old-dir new-list)) ;case '("abc" :wild)
(T (push (MAC-NAME-VALIDATION (string old-dir) (send self :directory-length)) new-list)))
)
))))))
(COND ((AND (STRINGP new-name) (STRINGP new-type)) ;
;;; periods in the TYPE component throw this scheme off.
(LET ((name-and-type (STRING-APPEND new-name #\. new-type)))
(MULTIPLE-VALUE-SETQ (new-name new-type)
(MAC-PARSE-NAME-AND-TYPE name-and-type self))))
((stringp new-name)
(SETF new-name
(MAC-NAME-VALIDATION new-name
(send self :name-length new-type))))
((stringp new-type)
(SETF new-type (MAC-NAME-VALIDATION
new-type
(send self :type-length new-name)))))
(WHEN new-device (SETF (GETF options :device) new-device)) ;05-13-88 DAB
(WHEN new-directory (SETF (GETF options :directory) new-directory)) ;05-13-88 DAB
(WHEN (GETF options :name) (SETF (GETF options :name) new-name))
(WHEN (GETF options :type) (SETF (GETF options :type) new-type))
;;; Lines commented out by JPR. We want version numbers.
; (when (getf options :version)
; (setf (getf options :version) :unspecific)) ;03-18-88 DAB for AB
) ;3.11.88
(APPLY #'MAKE-PATHNAME-1 :STARTING-PATHNAME (OR STARTING-PATHNAME SELF)
:PARSING-PATHNAME SELF OPTIONS))