Ignore:
Timestamp:
Oct 5, 2006, 12:07:26 PM (13 years ago)
Author:
gb
Message:

Try to get line-termination/external-format stuff working.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/ccl/level-1/l1-sysio.lisp

    r5276 r5293  
    2020  (octet-pos 0 :type fixnum)            ; current io position in octets
    2121  (fileeof 0 :type fixnum)              ; file length in elements
    22   (input-filter #'false)
    23   (output-filter #'false)
     22  (input-filter nil)
     23  (output-filter nil)
    2424  (line-termination :unix))
    2525
     26
     27(defun install-line-termination-filters (file-ioblock line-termination in-p out-p)
     28  (let* ((inferred-macos nil))
     29    (if (eq line-termination :inferred)
     30      (if in-p
     31        (if (eq (setq line-termination (infer-line-termination file-ioblock))
     32                :macos)
     33          (setq inferred-macos t))
     34        (setq line-termination :unix)))
     35    (setf (file-ioblock-line-termination file-ioblock) line-termination)
     36    (when (eq line-termination :macos)
     37      (let* ((encoding (or (file-ioblock-encoding file-ioblock)
     38                           (get-character-encoding nil)))
     39             (element-size (character-encoding-code-unit-size encoding))
     40             (native-byte-order (ioblock-native-byte-order file-ioblock)))
     41        (when in-p
     42          (setf (file-ioblock-input-filter file-ioblock)
     43                (case element-size
     44                  (8 'u8-translate-cr-to-lf)
     45                  (16 (if #+big-endian-target native-byte-order
     46                          #+little-endian-target (not native-byte-order)
     47                        'big-endian-u16-translate-cr-to-lf
     48                        'little-endian-swapped-u16-translate-cr-to-lf))
     49                  (32 (if #+big-endian-target native-byte-order
     50                          #+little-endian-target (not native-byte-order)
     51                        'big-endian-u32-translate-cr-to-lf
     52                        'little-endian-swapped-u32-translate-cr-to-lf))))
     53          (if inferred-macos
     54            (let* ((inbuf (file-ioblock-inbuf file-ioblock)))
     55              (funcall (file-ioblock-input-filter file-ioblock)
     56                       (io-buffer-buffer inbuf)
     57                       (io-buffer-count inbuf)))))
     58        (when out-p
     59          (setf (file-ioblock-output-filter file-ioblock)
     60                (case element-size
     61                  (8 'u8-translate-lf-to-cr)
     62                  (16 (if native-byte-order
     63                        'u16-translate-lf-to-cr
     64                        'swapped-u16-translate-lf-to-cr))
     65                  (32 (if native-byte-order
     66                        'u32-translate-lf-to-cr
     67                        'swapped-u32-translate-lf-to-cr)))))
     68        line-termination))))
    2669
    2770;;; The file-ioblock-octet-pos field is the (octet) position
     
    58101        (setf (schar string i) #\Return)))))
    59102
    60 (defun infer-external-format (file-stream)
    61   (with-stream-ioblock-input (ioblock file-stream :speedy t)
    62     (setf (file-stream-external-format file-stream)
    63           (if (eq (funcall (ioblock-peek-char-function ioblock) ioblock)
    64                   :eof)
    65             :unix
    66             (let* ((inbuf (ioblock-inbuf ioblock))
    67                    (string (io-buffer-buffer inbuf))
    68                    (n (io-buffer-count inbuf)))
    69               (declare (simple-base-string string)
    70                        (fixnum n))
    71               (dotimes (i n :unix)
    72                 (let* ((ch (schar string i)))
    73                   (if (eq ch #\Linefeed)
    74                     (return :unix))
    75                   (when (eq ch #\Return)
    76                     (translate-cr-to-lf ioblock)
    77                     (return :macos)))))))))
    78 
    79 (defvar *default-external-format* :unix
     103(defun infer-line-termination (file-ioblock)
     104  (let* ((encoding (or (file-ioblock-encoding file-ioblock)
     105                       (get-character-encoding nil)))
     106         (unit-size (character-encoding-code-unit-size encoding))
     107         (octets-per-unit (ash unit-size -3))
     108         (native-byte-order (file-ioblock-native-byte-order file-ioblock))
     109         (little-endian #+little-endian-target native-byte-order
     110                        #+big-endian-target (not native-byte-order))
     111         (leading-zeros (if little-endian
     112                          0
     113                          (1- octets-per-unit)))
     114         (trailing-zeros (if (not little-endian)
     115                           0
     116                           (1- octets-per-unit)))
     117         (cr (char-code #\Return))
     118         (lf (char-code #\linefeed))
     119         (inbuf (file-ioblock-inbuf file-ioblock))
     120         (buffer (io-buffer-buffer inbuf))
     121         (n (io-buffer-count inbuf)))
     122    (if (zerop n)
     123      (setq n (fd-stream-advance (file-ioblock-stream file-ioblock)
     124                                 file-ioblock
     125                                 t)))
     126    (do* ((i 0 (+ i octets-per-unit))
     127          (code))
     128         ((= i n) :unix)
     129      (when (and (dotimes (k leading-zeros t)
     130                   (unless (zerop (the (unsigned-byte 8) (aref buffer (+ i k))))
     131                     (return)))
     132                 (setq code (aref buffer (+ i leading-zeros)))
     133                 (dotimes (k trailing-zeros t)
     134                   (unless (zerop (the (unsigned-byte 8) (aref buffer (+ i 1 leading-zeros k))))
     135                     (return))))
     136        (if (= code cr)
     137          (return :macos)
     138          (if (= code lf)
     139            (return :unix)))))))
     140
     141
     142(defvar *known-line-termination-formats* '(:unix :macos :inferred))
     143
     144(defvar *default-external-format* :unix)
     145
     146(defvar *default-file-character-encoding* nil)
     147
     148(defmethod default-character-encoding ((domain (eql :file)))
     149  *default-file-character-encoding*)
     150
     151(defvar *default-line-termination* :unix
    80152  "The value of this variable is used when :EXTERNAL-FORMAT is
    81153unspecified or specified as :DEFAULT. It can meaningfully be given any
     
    87159is :UNIX.")
    88160
    89 (defparameter *external-format-translations*
    90   '((:unix nil nil)
    91     (:macos translate-cr-to-lf translate-lf-to-cr))
    92   "an alist: external-format-name, input-translation-function (or NIL),
    93    output-translation-function (or NIL)")
     161(defun normalize-external-format (domain external-format)
     162  (cond ((listp external-format)
     163         (unless (plistp external-format)
     164           (error "External-format ~s is not a property list." external-format))
     165         (let* ((character-encoding (getf external-format :character-encoding :default))
     166                (line-termination (getf external-format :line-termination :default)))
     167           (when (or (eq character-encoding :default)
     168                     (eq line-termination :default))
     169             (setq external-format (copy-list external-format))
     170             (if (eq line-termination :default)
     171               (setf (getf external-format :line-termination)
     172                     (setq line-termination *default-line-termination*)))
     173             (unless (member line-termination *known-line-termination-formats*)
     174               (error "~S is not a known line-termination format." line-termination))
     175             (if (eq character-encoding :default)
     176               (setf (getf external-format :character-encoding)
     177                     (setq character-encoding
     178                           (default-character-encoding domain))))
     179             (unless (lookup-character-encoding character-encoding)
     180               (error "~S is not the name of a known characer encoding."
     181                      character-encoding)))
     182           external-format))
     183        ((eq external-format :default)
     184         (normalize-external-format domain nil))
     185        ((lookup-character-encoding external-format)
     186         (normalize-external-format domain `(:character-encoding ,external-format)))
     187        ((member external-format *known-line-termination-formats*)
     188         (normalize-external-format domain `(:line-termination ,external-format)))
     189        (t
     190         (error "Invalid external-format: ~s" external-format))))
     191               
     192           
     193   
     194
    94195
    95196(defun file-stream-force-output (stream ioblock count finish-p)
    96   (let* ((filter (caddr (assoc (file-stream-external-format stream)
    97                                *external-format-translations*
    98                                :test #'eq))))
     197  (let* ((filter (file-ioblock-output-filter ioblock)))
    99198    (when filter
    100       (funcall filter ioblock count))
     199      (let* ((buffer (io-buffer-buffer (file-ioblock-outbuf ioblock))))
     200        (funcall filter buffer count)))
    101201    (fd-stream-force-output stream ioblock count finish-p)))
    102202
     
    391491
    392492
    393 (defun set-basic-stream-prototype (class)
    394   (when (subtypep class 'basic-stream)
    395     (setf (%class.prototype class) (or (%class.prototype class)
    396                                        (allocate-basic-stream class)))
    397     (dolist (subclass (class-direct-subclasses class))
    398       (set-basic-stream-prototype subclass))))
    399 
    400 (set-basic-stream-prototype (find-class 'basic-stream))
     493
    401494
    402495;;; This stuff is a lot simpler if we restrict the hair to the
     
    450543(defun file-stream-advance (stream file-ioblock read-p)
    451544  (let* ((n (fd-stream-advance stream file-ioblock read-p))
    452            (filter (cadr (assoc (stream-external-format stream)
    453                                 *external-format-translations*
    454                                 :test #'eq))))
    455       (if filter
    456         (funcall filter file-ioblock))
     545         (filter (file-ioblock-input-filter file-ioblock)))
     546      (when (and filter n (> n 0))
     547        (let* ((buf (file-ioblock-inbuf file-ioblock))
     548               (vector (io-buffer-buffer buf)))
     549          (funcall filter vector n)))
    457550      n))
    458551 
     
    748841                       (char-p (or (eq element-type 'character)
    749842                                   (subtypep element-type 'character)))
    750                        (infer nil)
    751843                       (real-external-format
    752                         (if (and char-p in-p)
    753                           (progn
    754                             (if (eq external-format :default)
    755                               (setq external-format *default-external-format*))
    756                             (if (eq external-format :inferred)
    757                               (setq infer t external-format :unix)
    758                               (unless (assoc external-format
    759                                              *external-format-translations*
    760                                              :test #'eq)
    761                                 (setq external-format :unix)))
    762                             external-format)
    763                           :binary))
     844                        (if char-p
     845                          (normalize-external-format :file external-format)
     846                          '(:binary :t)))
     847                       (line-termination (getf real-external-format :line-termination))
     848                       (encoding (getf real-external-format :character-encoding))
    764849                       (class-name (select-stream-class class in-p out-p char-p))
    765850                       (class (find-class class-name))
     
    782867                                           class direction))
    783868                                 :device fd
     869                                 :encoding encoding
    784870                                 :external-format real-external-format
    785871                                 :sharing sharing
     
    791877                  (setf (file-ioblock-fileeof ioblock)
    792878                        (ioblock-octets-to-elements ioblock (fd-size fd)))
    793                   (if infer
    794                     (infer-external-format fstream))
     879                  (install-line-termination-filters ioblock line-termination in-p out-p)
    795880                  (cond ((eq if-exists :append)
    796881                         (file-position fstream :end))
Note: See TracChangeset for help on using the changeset viewer.