Changeset 11101

Timestamp:

02/27/06 16:06:34 (3 years ago)

Author:

rtoy

Message:

When reverting a file, don't delete the file if there was no
original. This is the solution from Carl, for a bug reported by
Madhu, cmucl-imp, 2006-02-19.

Files:

• trunk/src/code/fd-stream.lisp (modified) (15 diffs)

trunk/src/code/fd-stream.lisp

@@ -22 +22 @@
 (export '(fd-stream fd-stream-p fd-stream-fd make-fd-stream
           io-timeout beep *beep-function* output-raw-bytes
-          *tty* *stdin* *stdout* *stderr*))
+          *tty* *stdin* *stdout* *stderr*
+          binary-text-stream))
 
 
@@ -123 +124 @@
           (fd-stream-name fd-stream)))
 
+;; CMUCL extension.  This is a FD-STREAM, but it allows reading and
+;; writing of 8-bit characters and unsigned bytes from the stream.
+(defstruct (binary-text-stream
+             (:print-function %print-binary-text-stream)
+             (:constructor %make-binary-text-stream)
+             (:include fd-stream)))
+
+(defun %print-binary-text-stream (fd-stream stream depth)
+  (declare (ignore depth) (stream stream))
+  (format stream "#<Binary-text Stream for ~A>"
+          (fd-stream-name fd-stream)))
 
 (define-condition io-timeout (stream-error)
@@ -593 +605 @@
                         (- buflen tail))
       (cond ((null count)
-             (if (eql errno unix:ewouldblock)
-                 (progn
-                   (unless #-mp (system:wait-until-fd-usable
-                                 fd :input (fd-stream-timeout stream))
-                           #+mp (mp:process-wait-until-fd-usable
-                                 fd :input (fd-stream-timeout stream))
-                     (error 'io-timeout :stream stream :direction :read))
-                   (do-input stream))
-                 (error "Error reading ~S: ~A"
-                        stream
-                        (unix:get-unix-error-msg errno))))
+             ;; What kinds of errors do we want to look at and what do
+             ;; we want them to do?
+             (cond ((eql errno unix:ewouldblock)
+                    (unless #-mp (system:wait-until-fd-usable
+                                  fd :input (fd-stream-timeout stream))
+                            #+mp (mp:process-wait-until-fd-usable
+                                  fd :input (fd-stream-timeout stream))
+                            (error 'io-timeout :stream stream :direction :read))
+                    (do-input stream))
+                   ((eql errno unix:econnreset)
+                    (error 'socket-error
+                           :format-control "Socket connection reset: ~A"
+                           :format-arguments (list (unix:get-unix-error-msg errno))
+                           :errno errno))
+                   (t
+                    (error "Error reading ~S: ~A"
+                           stream
+                           (unix:get-unix-error-msg errno)))))
             ((zerop count)
              (setf (fd-stream-listen stream) :eof)
@@ -631 +650 @@
 ;;;   Macro to wrap around all input routines to handle eof-error noise.
 ;;;
-(defmacro input-wrapper ((stream bytes eof-error eof-value) &body read-forms)
+(defmacro input-wrapper ((stream bytes eof-error eof-value &optional type) &body read-forms)
   (let ((stream-var (gensym))
         (element-var (gensym)))
@@ -637 +656 @@
        (if (fd-stream-unread ,stream-var)
            (prog1
-               (fd-stream-unread ,stream-var)
+               ,(if (eq type 'character) 
+                    `(fd-stream-unread ,stream-var)
+                    `(char-code (fd-stream-unread ,stream-var)))
              (setf (fd-stream-unread ,stream-var) nil)
              (setf (fd-stream-listen ,stream-var) nil))
@@ -659 +680 @@
   `(progn
      (defun ,name (stream eof-error eof-value)
-       (input-wrapper (stream ,size eof-error eof-value)
+       (input-wrapper (stream ,size eof-error eof-value ,type)
          (let ((,sap (fd-stream-ibuf-sap stream))
                (,head (fd-stream-ibuf-head stream)))
@@ -865 +886 @@
          (assert (= 1 (fd-stream-element-size stream)))
          (setf (sap-ref-8 buffer start) (char-code (read-char stream))))
+        (string 
+         (setf (aref buffer start) (read-char stream)))
         (vector
-         (setf (aref buffer start) (read-char stream))))
+         (setf (aref buffer start) (char-code(read-char stream)))))
       (return-from fd-stream-read-n-bytes
         (1+ (fd-stream-read-n-bytes stream buffer (1+ start) (1- requested)
@@ -968 +991 @@
 ;;; to calling this routine.
 ;;;
-(defun set-routines (stream type input-p output-p buffer-p)
+
+(defun set-routines (stream type input-p output-p buffer-p &key binary-stream-p)
   (let ((target-type (case type
                        ((:default unsigned-byte)
@@ -1000 +1024 @@
             (setf (fd-stream-in stream) routine
                   (fd-stream-bin stream) #'ill-bin)
-            (setf (fd-stream-in stream) #'ill-in
+            (setf (fd-stream-in stream) (if (and binary-stream-p
+                                                 (eql size 1))
+                                            (pick-input-routine 'character) 
+                                            #'ill-in)
                   (fd-stream-bin stream) routine))
         (when (or (eql size 1)
@@ -1313 +1340 @@
                                  (format nil "file ~S" file)
                                  (format nil "descriptor ~D" fd)))
-                       auto-close)
+                       auto-close
+                       binary-stream-p)
   (declare (type index fd) (type (or index null) timeout)
            (type (member :none :line :full) buffering))
@@ -1330 +1358 @@
         ((not (or input output))
          (error "File descriptor must be opened either for input or output.")))
-  (let ((stream (%make-fd-stream :fd fd
-                                 :name name
-                                 :file file
-                                 :original original
-                                 :delete-original delete-original
-                                 :pathname pathname
-                                 :buffering buffering
-                                 :timeout timeout)))
-    (set-routines stream element-type input output input-buffer-p)
+  (let ((stream (if binary-stream-p
+                    (%make-binary-text-stream :fd fd
+                                              :name name
+                                              :file file
+                                              :original original
+                                              :delete-original delete-original
+                                              :pathname pathname
+                                              :buffering buffering
+                                              :timeout timeout)
+                    (%make-fd-stream :fd fd
+                                     :name name
+                                     :file file
+                                     :original original
+                                     :delete-original delete-original
+                                     :pathname pathname
+                                     :buffering buffering
+                                     :timeout timeout))))
+    (set-routines stream element-type input output input-buffer-p
+                  :binary-stream-p binary-stream-p)
     (when (and auto-close (fboundp 'finalize))
       (finalize stream
@@ -1605 +1643 @@
                                 (if-exists nil if-exists-given)
                                 (if-does-not-exist nil if-does-not-exist-given)
-                                (external-format :default))
+                                (external-format :default)
+                                class)
   (declare (type pathname pathname)
            (type (member :input :output :io :probe) direction)
@@ -1618 +1657 @@
       (case direction
         ((:input :output :io)
+         ;; We use the :class option to tell us if we want a
+         ;; binary-text stream or not.
          (make-fd-stream fd
                          :input (member direction '(:input :io))
@@ -1627 +1668 @@
                          :pathname pathname
                          :input-buffer-p t
-                         :auto-close t))
+                         :auto-close t
+                         :binary-stream-p class))
         (:probe
          (let ((stream (%make-fd-stream :name namestring :fd fd
@@ -1698 +1740 @@
            (remf options :output-handle)
            (apply #'open-fd-stream filespec options))
+          ((eq class 'binary-text-stream)
+           ;; Like fd-stream, but binary and text allowed.  This is
+           ;; indicated by leaving the :class option around for
+           ;; open-fd-stream to see.
+           (remf options :mapped)
+           (remf options :input-handle)
+           (remf options :output-handle)
+           (apply #'open-fd-stream filespec options))
           ((subtypep class 'stream:simple-stream)
            (when element-type-given