Some work on open.

Pascal J. Bourguignon [2015-04-03 06:18]
Some work on open.
Filename
vfs-file-stream.lisp
diff --git a/vfs-file-stream.lisp b/vfs-file-stream.lisp
index 6d3e8bd..f26ff17 100644
--- a/vfs-file-stream.lisp
+++ b/vfs-file-stream.lisp
@@ -78,7 +78,7 @@


 (define-stream-methods file-stream
-    (stream-external-format (%stream-external-format stream))
+  (stream-external-format (%stream-external-format stream))
   (file-length   (length (contents (%file-stream-contents stream))))
   (file-string-length
    (etypecase object
@@ -99,10 +99,10 @@


 (defun open (filespec &key (direction :input)
-             (element-type 'character)
-             (if-exists nil)
-             (if-does-not-exist nil)
-             (external-format :default))
+                        (element-type 'character)
+                        (if-exists nil)
+                        (if-does-not-exist nil)
+                        (external-format :default))

   (check-type direction (member :input :output :io :probe))
   (check-type if-exists (member :error :new-version :rename :rename-and-delete
@@ -164,87 +164,87 @@
                      (rename-file file old)))))

       (let ((contents (file-entry path)))
-
-       ;; filespec  ¬N.T     ¬N.T.3<NEWEST ¬N.T.3>NEWEST  N.T.3=NEWEST  N.T.3<NEWEST
-       ;;   N.T     no exist     newest        newest       newest         newest
-       ;;   N.T.3   no exist     no exist      no exist     newest      old version
-       ;;                     create newest  create newest
-       (ecase direction

-         ((:input :probe)
-          (if contents
-              (progn
-                ;; TODO: use CERROR to ignre the requested element-type
-                (assert (equal (element-type contents) element-type)
-                        () "~A: the element-type requested ~S must be identical to the element-type ~S of the file ~S"
-                        'open element-type (element-type contents)  path)
-                (make-stream (file contents) (eql direction :input) t nil  nil :start))
-              (ecase if-does-not-exist
-                ((:error)
-                 (error (make-condition
-                         'simple-file-error
-                         :pathname path
-                         :format-control "~A: file ~S does not exist"
-                         :format-arguments (list 'open path))))
-                ((:create)
-                 (make-stream (new-file path element-type) (eql direction :input) t nil  nil :start))
-                ((nil)
-                 (return-from open nil)))))
-
-
-         ((:output :io)
-          (if contents
-              ;; file exists:
-              (ecase if-exists
-                ((:error)
-                 (error (make-condition
-                         'simple-file-error
-                         :pathname path
-                         :format-control "~A: file ~S already exists"
-                         :format-arguments (list 'open path))))
-                ((:new-version)
-                 (make-stream (new-version (file contents) element-type)
-                              t (eql direction :io) t  nil :start))
-                ((:rename)
-                 (rename-old path)
-                 (make-stream (new-file path element-type)
-                              t (eql direction :io) t  nil :start))
-                ((:rename-and-delete)
-                 (let ((old nil))
-                   (unwind-protect
-                        (progn
-                          (setf old (rename-old path))
-                          (make-stream (new-file path element-type)
-                                       t (eql direction :io) t  nil :start))
-                     (when old
-                       (delete-file old)))))
-                ((:overwrite)
-                 (make-stream (if (eql contents (newest (file contents)))
-                                  (file contents)
-                                  (copy-new-version contents))
-                              t (eql direction :io) t nil :start))
-                ((:append)
-                 (make-stream (if (eql contents (newest (file contents)))
-                                  (file contents)
-                                  (copy-new-version contents))
-                              t (eql direction :io) t nil :end))
-                ((:supersede)
-                 (make-stream (new-file/unlinked path element-type)
-                              t (eql direction :io) t  nil :start))
-                ((nil)
-                 (return-from open nil)))
-              ;; file does not exist:
-              (ecase if-does-not-exist
-                ((:error)
-                 (error (make-condition
-                         'simple-file-error
-                         :pathname path
-                         :format-control "~A: file ~S does not exist"
-                         :format-arguments (list 'open path))))
-                ((:create)
-                 (make-stream (new-file path element-type) t (eql direction :io) t  t :start))
-                ((nil)
-                 (return-from open nil))))))))))
+        ;; filespec  ¬N.T     ¬N.T.3<NEWEST ¬N.T.3>NEWEST  N.T.3=NEWEST  N.T.3<NEWEST
+        ;;   N.T     no exist     newest        newest       newest         newest
+        ;;   N.T.3   no exist     no exist      no exist     newest      old version
+        ;;                     create newest  create newest
+        (ecase direction
+
+          ((:input :probe)
+           (if contents
+               (progn
+                 ;; TODO: use CERROR to ignre the requested element-type
+                 (assert (equal (element-type contents) element-type)
+                         () "~A: the element-type requested ~S must be identical to the element-type ~S of the file ~S"
+                         'open element-type (element-type contents)  path)
+                 (make-stream (file contents) (eql direction :input) t nil  nil :start))
+               (ecase if-does-not-exist
+                 ((:error)
+                  (error (make-condition
+                          'simple-file-error
+                          :pathname path
+                          :format-control "~A: file ~S does not exist"
+                          :format-arguments (list 'open path))))
+                 ((:create)
+                  (make-stream (new-file path element-type) (eql direction :input) t nil  nil :start))
+                 ((nil)
+                  (return-from open nil)))))
+
+
+          ((:output :io)
+           (if contents
+               ;; file exists:
+               (ecase if-exists
+                 ((:error)
+                  (error (make-condition
+                          'simple-file-error
+                          :pathname path
+                          :format-control "~A: file ~S already exists"
+                          :format-arguments (list 'open path))))
+                 ((:new-version)
+                  (make-stream (new-version (file contents) element-type)
+                               t (eql direction :io) t  nil :start))
+                 ((:rename)
+                  (rename-old path)
+                  (make-stream (new-file path element-type)
+                               t (eql direction :io) t  nil :start))
+                 ((:rename-and-delete)
+                  (let ((old nil))
+                    (unwind-protect
+                         (progn
+                           (setf old (rename-old path))
+                           (make-stream (new-file path element-type)
+                                        t (eql direction :io) t  nil :start))
+                      (when old
+                        (delete-file old)))))
+                 ((:overwrite)
+                  (make-stream (if (eql contents (newest (file contents)))
+                                   (file contents)
+                                   (copy-new-version contents))
+                               t (eql direction :io) t nil :start))
+                 ((:append)
+                  (make-stream (if (eql contents (newest (file contents)))
+                                   (file contents)
+                                   (copy-new-version contents))
+                               t (eql direction :io) t nil :end))
+                 ((:supersede)
+                  (make-stream (new-file/unlinked path element-type)
+                               t (eql direction :io) t  nil :start))
+                 ((nil)
+                  (return-from open nil)))
+               ;; file does not exist:
+               (ecase if-does-not-exist
+                 ((:error)
+                  (error (make-condition
+                          'simple-file-error
+                          :pathname path
+                          :format-control "~A: file ~S does not exist"
+                          :format-arguments (list 'open path))))
+                 ((:create)
+                  (make-stream (new-file path element-type) t (eql direction :io) t  t :start))
+                 ((nil)
+                  (return-from open nil))))))))))



@@ -284,28 +284,28 @@
             (replace data sequence :start1 position :start2 start :end2 end)
             (setf position new-position))
           (error 'simple-stream-error
-                     :stream stream
-                     :format-control "data too big to be written on stream ~S (~A+~A=~A>~A)"
-                     :format-arguments (list stream
-                                             position size new-position *maximum-file-size*))))))
+                 :stream stream
+                 :format-control "data too big to be written on stream ~S (~A+~A=~A>~A)"
+                 :format-arguments (list stream
+                                         position size new-position *maximum-file-size*))))))

 (defun whitespacep (ch)
   (position  ch #(#\Space #\Newline #\Tab #\Linefeed #\Page #\Return)))


 (define-stream-methods file-input-stream
-    (file-position
-     (call-next-method)
-     (with-accessors ((contents %file-stream-contents)
-                      (position %file-stream-position)) stream
-       (if position-spec
-           (if (< -1 position-spec (length (contents contents)))
-               (setf position position-spec)
-               (error 'simple-stream-error
-                      :stream stream
-                      :format-control "~A: invalid position ~A on stream ~S"
-                      :format-arguments (list 'file-position position-spec stream))))
-       position))
+  (file-position
+   (call-next-method)
+   (with-accessors ((contents %file-stream-contents)
+                    (position %file-stream-position)) stream
+     (if position-spec
+         (if (< -1 position-spec (length (contents contents)))
+             (setf position position-spec)
+             (error 'simple-stream-error
+                    :stream stream
+                    :format-control "~A: invalid position ~A on stream ~S"
+                    :format-arguments (list 'file-position position-spec stream))))
+     position))

   (read-byte         (!read-element       stream eof-error-p eof-value))
   (read-char         (!read-element input-stream eof-error-p eof-value))
@@ -369,18 +369,18 @@
 (defvar *newline* (string #\newline))

 (define-stream-methods file-output-stream
-    (file-position
-     (call-next-method)
-     (with-accessors ((contents %file-stream-contents)
-                      (position %file-stream-position)) stream
-       (if position-spec
-           (if (< -1 position-spec *maximum-file-size*)
-               (setf position position-spec)
-               (error 'simple-stream-error
-                      :stream stream
-                      :format-control "~A: invalid position ~A on stream ~S"
-                      :format-arguments (list 'file-position position-spec stream))))
-       position))
+  (file-position
+   (call-next-method)
+   (with-accessors ((contents %file-stream-contents)
+                    (position %file-stream-position)) stream
+     (if position-spec
+         (if (< -1 position-spec *maximum-file-size*)
+             (setf position position-spec)
+             (error 'simple-stream-error
+                    :stream stream
+                    :format-control "~A: invalid position ~A on stream ~S"
+                    :format-arguments (list 'file-position position-spec stream))))
+     position))

   (write-byte     (!write-element stream        (vector byte)      0 1)
                   byte)
ViewGit