/[cmucl]/src/code/fd-stream.lisp
ViewVC logotype

Diff of /src/code/fd-stream.lisp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.99 by rtoy, Mon Apr 19 02:18:03 2010 UTC revision 1.100 by rtoy, Tue Apr 20 17:57:44 2010 UTC
# Line 288  Line 288 
288    (:report    (:report
289     (lambda (condition stream)     (lambda (condition stream)
290       (declare (stream stream))       (declare (stream stream))
291       (format stream _"Timeout ~(~A~)ing ~S."       (format stream (intl:gettext "Timeout ~(~A~)ing ~S.")
292               (io-timeout-direction condition)               (io-timeout-direction condition)
293               (stream-error-stream condition)))))               (stream-error-stream condition)))))
294    
# Line 322  Line 322 
322                           length)                           length)
323        (cond ((not count)        (cond ((not count)
324               (if (= errno unix:ewouldblock)               (if (= errno unix:ewouldblock)
325                   (error _"Write would have blocked, but SERVER told us to go.")                   (error (intl:gettext "Write would have blocked, but SERVER told us to go."))
326                   (error _"While writing ~S: ~A"                   (error (intl:gettext "While writing ~S: ~A")
327                          stream (unix:get-unix-error-msg errno))))                          stream (unix:get-unix-error-msg errno))))
328              ((eql count length) ; Hot damn, it worked.              ((eql count length) ; Hot damn, it worked.
329               (when reuse-sap               (when reuse-sap
# Line 611  Line 611 
611             (bytes (- end start))             (bytes (- end start))
612             (newtail (+ tail bytes)))             (newtail (+ tail bytes)))
613        (cond ((minusp bytes) ; Error case        (cond ((minusp bytes) ; Error case
614               (cerror _"Just go on as if nothing happened..."               (cerror (intl:gettext "Just go on as if nothing happened...")
615                       _"~S called with :END before :START!"                       (intl:gettext "~S called with :END before :START!")
616                       'output-raw-bytes))                       'output-raw-bytes))
617              ((zerop bytes)) ; Easy case              ((zerop bytes)) ; Easy case
618              ((<= bytes space)              ((<= bytes space)
# Line 892  Line 892 
892                             :format-arguments (list (unix:get-unix-error-msg errno))                             :format-arguments (list (unix:get-unix-error-msg errno))
893                             :errno errno))                             :errno errno))
894                     (t                     (t
895                      (error _"Error reading ~S: ~A"                      (error (intl:gettext "Error reading ~S: ~A")
896                             stream                             stream
897                             (unix:get-unix-error-msg errno)))))                             (unix:get-unix-error-msg errno)))))
898              ((zerop count)              ((zerop count)
# Line 1282  Line 1282 
1282                                    now-needed)                                    now-needed)
1283                  (declare (type (or index null) count))                  (declare (type (or index null) count))
1284                  (unless count                  (unless count
1285                    (error _"Error reading ~S: ~A" stream                    (error (intl:gettext "Error reading ~S: ~A") stream
1286                           (unix:get-unix-error-msg err)))                           (unix:get-unix-error-msg err)))
1287                  (decf now-needed count)                  (decf now-needed count)
1288                  (if eof-error-p                  (if eof-error-p
# Line 1302  Line 1302 
1302                  (unix:unix-read (fd-stream-fd stream) sap len)                  (unix:unix-read (fd-stream-fd stream) sap len)
1303                (declare (type (or index null) count))                (declare (type (or index null) count))
1304                (unless count                (unless count
1305                  (error _"Error reading ~S: ~A" stream                  (error (intl:gettext "Error reading ~S: ~A") stream
1306                         (unix:get-unix-error-msg err)))                         (unix:get-unix-error-msg err)))
1307                (when (and eof-error-p (zerop count))                (when (and eof-error-p (zerop count))
1308                  (error 'end-of-file :stream stream))                  (error 'end-of-file :stream stream))
# Line 1368  Line 1368 
1368            (routine type size)            (routine type size)
1369            (pick-input-routine target-type)            (pick-input-routine target-type)
1370          (unless routine          (unless routine
1371            (error _"Could not find any input routine for ~S" target-type))            (error (intl:gettext "Could not find any input routine for ~S") target-type))
1372          (setf (fd-stream-ibuf-sap stream) (next-available-buffer))          (setf (fd-stream-ibuf-sap stream) (next-available-buffer))
1373          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)          (setf (fd-stream-ibuf-length stream) bytes-per-buffer)
1374          (setf (fd-stream-ibuf-tail stream) 0)          (setf (fd-stream-ibuf-tail stream) 0)
# Line 1426  Line 1426 
1426            (routine type size)            (routine type size)
1427            (pick-output-routine target-type (fd-stream-buffering stream))            (pick-output-routine target-type (fd-stream-buffering stream))
1428          (unless routine          (unless routine
1429            (error _"Could not find any output routine for ~S buffered ~S."            (error (intl:gettext "Could not find any output routine for ~S buffered ~S.")
1430                   (fd-stream-buffering stream)                   (fd-stream-buffering stream)
1431                   target-type))                   target-type))
1432          (setf (fd-stream-obuf-sap stream) (next-available-buffer))          (setf (fd-stream-obuf-sap stream) (next-available-buffer))
# Line 1449  Line 1449 
1449    
1450      (when (and input-size output-size      (when (and input-size output-size
1451                 (not (eql input-size output-size)))                 (not (eql input-size output-size)))
1452        (error _"Element sizes for input (~S:~S) and output (~S:~S) differ?"        (error (intl:gettext "Element sizes for input (~S:~S) and output (~S:~S) differ?")
1453               input-type input-size               input-type input-size
1454               output-type output-size))               output-type output-size))
1455      (setf (fd-stream-element-size stream)      (setf (fd-stream-element-size stream)
# Line 1467  Line 1467 
1467                  ((subtypep output-type input-type)                  ((subtypep output-type input-type)
1468                   output-type)                   output-type)
1469                  (t                  (t
1470                   (error _"Input type (~S) and output type (~S) are unrelated?"                   (error (intl:gettext "Input type (~S) and output type (~S) are unrelated?")
1471                          input-type                          input-type
1472                          output-type))))))                          output-type))))))
1473    
# Line 1483  Line 1483 
1483      (multiple-value-bind (okay err)      (multiple-value-bind (okay err)
1484          (unix:unix-rename original filename)          (unix:unix-rename original filename)
1485        (unless okay        (unless okay
1486            (cerror _"Go on as if nothing bad happened."            (cerror (intl:gettext "Go on as if nothing bad happened.")
1487                    _"Could not restore ~S to its original contents: ~A"                    (intl:gettext "Could not restore ~S to its original contents: ~A")
1488                    filename (unix:get-unix-error-msg err))))))                    filename (unix:get-unix-error-msg err))))))
1489    
1490  ;;; DELETE-ORIGINAL -- internal  ;;; DELETE-ORIGINAL -- internal
# Line 1618  Line 1618 
1618         (error 'simple-type-error         (error 'simple-type-error
1619                :datum stream                :datum stream
1620                :expected-type 'file-stream                :expected-type 'file-stream
1621                :format-control _"~s is not a stream associated with a file."                :format-control (intl:gettext "~s is not a stream associated with a file.")
1622                :format-arguments (list stream)))                :format-arguments (list stream)))
1623       (multiple-value-bind       (multiple-value-bind
1624           (okay dev ino mode nlink uid gid rdev size           (okay dev ino mode nlink uid gid rdev size
# Line 1628  Line 1628 
1628                          atime mtime ctime blksize blocks))                          atime mtime ctime blksize blocks))
1629         (unless okay         (unless okay
1630           (error 'simple-file-error           (error 'simple-file-error
1631                  :format-control _"Error fstating ~S: ~A"                  :format-control (intl:gettext "Error fstating ~S: ~A")
1632                  :format-arguments (list stream (unix:get-unix-error-msg dev))))                  :format-arguments (list stream (unix:get-unix-error-msg dev))))
1633         (if (zerop mode)         (if (zerop mode)
1634             nil             nil
# Line 1689  Line 1689 
1689                   nil)                   nil)
1690                  (t                  (t
1691                   (system:with-interrupts                   (system:with-interrupts
1692                     (error _"Error lseek'ing ~S: ~A"                     (error (intl:gettext "Error lseek'ing ~S: ~A")
1693                            stream                            stream
1694                            (unix:get-unix-error-msg errno)))))))                            (unix:get-unix-error-msg errno)))))))
1695        (let ((offset 0)        (let ((offset 0)
# Line 1725  Line 1725 
1725                 (setf offset (* newpos (fd-stream-element-size stream))                 (setf offset (* newpos (fd-stream-element-size stream))
1726                       origin unix:l_set))                       origin unix:l_set))
1727                (t                (t
1728                 (error _"Invalid position given to file-position: ~S" newpos)))                 (error (intl:gettext "Invalid position given to file-position: ~S") newpos)))
1729          (multiple-value-bind          (multiple-value-bind
1730              (posn errno)              (posn errno)
1731              (unix:unix-lseek (fd-stream-fd stream) offset origin)              (unix:unix-lseek (fd-stream-fd stream) offset origin)
# Line 1734  Line 1734 
1734                  ((eq errno unix:espipe)                  ((eq errno unix:espipe)
1735                   nil)                   nil)
1736                  (t                  (t
1737                   (error _"Error lseek'ing ~S: ~A"                   (error (intl:gettext "Error lseek'ing ~S: ~A")
1738                          stream                          stream
1739                          (unix:get-unix-error-msg errno))))))))                          (unix:get-unix-error-msg errno))))))))
1740    
# Line 1785  Line 1785 
1785    (cond ((not (or input-p output-p))    (cond ((not (or input-p output-p))
1786           (setf input t))           (setf input t))
1787          ((not (or input output))          ((not (or input output))
1788           (error _"File descriptor must be opened either for input or output.")))           (error (intl:gettext "File descriptor must be opened either for input or output."))))
1789    (let ((stream (if binary-stream-p    (let ((stream (if binary-stream-p
1790                      (%make-binary-text-stream :fd fd                      (%make-binary-text-stream :fd fd
1791                                                :name name                                                :name name
# Line 1820  Line 1820 
1820        (finalize stream        (finalize stream
1821                  #'(lambda ()                  #'(lambda ()
1822                      (unix:unix-close fd)                      (unix:unix-close fd)
1823                      (format *terminal-io* _"** Closed ~A~%" name)                      (format *terminal-io* (intl:gettext "** Closed ~A~%") name)
1824                      (when original                      (when original
1825                        (revert-file file original)))))                        (revert-file file original)))))
1826      stream))      stream))
# Line 1884  Line 1884 
1884  (defun assure-one-of (item list what)  (defun assure-one-of (item list what)
1885    (unless (member item list)    (unless (member item list)
1886      (loop      (loop
1887        (cerror _"Enter new value for ~*~S"        (cerror (intl:gettext "Enter new value for ~*~S")
1888                _"~S is invalid for ~S. Must be one of~{ ~S~}"                (intl:gettext "~S is invalid for ~S. Must be one of~{ ~S~}")
1889                item                item
1890                what                what
1891                list)                list)
1892        (format (the stream *query-io*) _"Enter new value for ~S: " what)        (format (the stream *query-io*) (intl:gettext "Enter new value for ~S: ") what)
1893        (force-output *query-io*)        (force-output *query-io*)
1894        (setf item (read *query-io*))        (setf item (read *query-io*))
1895        (when (member item list)        (when (member item list)
# Line 1904  Line 1904 
1904  ;;;  ;;;
1905  (defun do-old-rename (namestring original)  (defun do-old-rename (namestring original)
1906    (unless (unix:unix-access namestring unix:w_ok)    (unless (unix:unix-access namestring unix:w_ok)
1907      (cerror _"Try to rename it anyway." _"File ~S is not writable." namestring))      (cerror (intl:gettext "Try to rename it anyway.") (intl:gettext "File ~S is not writable.") namestring))
1908    (multiple-value-bind    (multiple-value-bind
1909        (okay err)        (okay err)
1910        (unix:unix-rename namestring original)        (unix:unix-rename namestring original)
1911      (cond (okay t)      (cond (okay t)
1912            (t            (t
1913             (cerror _"Use :SUPERSEDE instead."             (cerror (intl:gettext "Use :SUPERSEDE instead.")
1914                     _"Could not rename ~S to ~S: ~A."                     (intl:gettext "Could not rename ~S to ~S: ~A.")
1915                     namestring                     namestring
1916                     original                     original
1917                     (unix:get-unix-error-msg err))                     (unix:get-unix-error-msg err))
# Line 1992  Line 1992 
1992                               (error 'simple-file-error                               (error 'simple-file-error
1993                                   :pathname pathname                                   :pathname pathname
1994                                   :format-control                                   :format-control
1995                                   _"Cannot open ~S for output: Is a directory."                                   (intl:gettext "Cannot open ~S for output: Is a directory.")
1996                                   :format-arguments (list name)))                                   :format-arguments (list name)))
1997                             (setf mode (logand orig-mode #o777))                             (setf mode (logand orig-mode #o777))
1998                             t)                             t)
# Line 2001  Line 2001 
2001                            (t                            (t
2002                             (error 'simple-file-error                             (error 'simple-file-error
2003                                    :pathname pathname                                    :pathname pathname
2004                                    :format-control _"Cannot find ~S: ~A"                                    :format-control (intl:gettext "Cannot find ~S: ~A")
2005                                    :format-arguments                                    :format-arguments
2006                                      (list name                                      (list name
2007                                        (unix:get-unix-error-msg err/dev)))))))))                                        (unix:get-unix-error-msg err/dev)))))))))
# Line 2031  Line 2031 
2031                    ((eql errno unix:enoent)                    ((eql errno unix:enoent)
2032                     (case if-does-not-exist                     (case if-does-not-exist
2033                       (:error                       (:error
2034                         (cerror _"Return NIL."                         (cerror (intl:gettext "Return NIL.")
2035                                 'simple-file-error                                 'simple-file-error
2036                                 :pathname pathname                                 :pathname pathname
2037                                 :format-control _"Error opening ~S, ~A."                                 :format-control (intl:gettext "Error opening ~S, ~A.")
2038                                 :format-arguments                                 :format-arguments
2039                                     (list pathname                                     (list pathname
2040                                           (unix:get-unix-error-msg errno))))                                           (unix:get-unix-error-msg errno))))
2041                       (:create                       (:create
2042                         (cerror _"Return NIL."                         (cerror (intl:gettext "Return NIL.")
2043                                 'simple-file-error                                 'simple-file-error
2044                                 :pathname pathname                                 :pathname pathname
2045                                 :format-control                                 :format-control
2046                                     _"Error creating ~S, path does not exist."                                     (intl:gettext "Error creating ~S, path does not exist.")
2047                                 :format-arguments (list pathname))))                                 :format-arguments (list pathname))))
2048                     (return nil))                     (return nil))
2049                    ((eql errno unix:eexist)                    ((eql errno unix:eexist)
2050                     (unless (eq nil if-exists)                     (unless (eq nil if-exists)
2051                       (cerror _"Return NIL."                       (cerror (intl:gettext "Return NIL.")
2052                               'simple-file-error                               'simple-file-error
2053                               :pathname pathname                               :pathname pathname
2054                               :format-control _"Error opening ~S, ~A."                               :format-control (intl:gettext "Error opening ~S, ~A.")
2055                               :format-arguments                               :format-arguments
2056                                   (list pathname                                   (list pathname
2057                                         (unix:get-unix-error-msg errno))))                                         (unix:get-unix-error-msg errno))))
2058                     (return nil))                     (return nil))
2059                    ((eql errno unix:eacces)                    ((eql errno unix:eacces)
2060                     (cerror _"Try again."                     (cerror (intl:gettext "Try again.")
2061                             'simple-file-error                             'simple-file-error
2062                             :pathname pathname                             :pathname pathname
2063                             :format-control _"Error opening ~S, ~A."                             :format-control (intl:gettext "Error opening ~S, ~A.")
2064                             :format-arguments                             :format-arguments
2065                                 (list pathname                                 (list pathname
2066                                       (unix:get-unix-error-msg errno))))                                       (unix:get-unix-error-msg errno))))
2067                    (t                    (t
2068                     (cerror _"Return NIL."                     (cerror (intl:gettext "Return NIL.")
2069                             'simple-file-error                             'simple-file-error
2070                             :pathname pathname                             :pathname pathname
2071                             :format-control _"Error opening ~S, ~A."                             :format-control (intl:gettext "Error opening ~S, ~A.")
2072                             :format-arguments                             :format-arguments
2073                                 (list pathname                                 (list pathname
2074                                       (unix:get-unix-error-msg errno)))                                       (unix:get-unix-error-msg errno)))
# Line 2190  Line 2190 
2190             (apply #'open-fd-stream filespec options))             (apply #'open-fd-stream filespec options))
2191            ((subtypep class 'stream:simple-stream)            ((subtypep class 'stream:simple-stream)
2192             (when element-type-given             (when element-type-given
2193               (cerror _"Do it anyway."               (cerror (intl:gettext "Do it anyway.")
2194                       _"Can't create simple-streams with an element-type."))                       (intl:gettext "Can't create simple-streams with an element-type.")))
2195             (when (and (eq class 'stream:file-simple-stream) mapped)             (when (and (eq class 'stream:file-simple-stream) mapped)
2196               (setq class 'stream:mapped-file-simple-stream)               (setq class 'stream:mapped-file-simple-stream)
2197               (setf (getf options :class) 'stream:mapped-file-simple-stream))               (setf (getf options :class) 'stream:mapped-file-simple-stream))
# Line 2208  Line 2208 
2208               (when stream               (when stream
2209                 (make-instance class :lisp-stream stream))))                 (make-instance class :lisp-stream stream))))
2210            (t            (t
2211             (error _"Unable to open streams of class ~S." class)))))             (error (intl:gettext "Unable to open streams of class ~S.") class)))))
2212    
2213  ;;;; Initialization.  ;;;; Initialization.
2214    

Legend:
Removed from v.1.99  
changed lines
  Added in v.1.100

  ViewVC Help
Powered by ViewVC 1.1.5