Changeset 5293
- Timestamp:
- Oct 5, 2006, 5:07:26 AM (18 years ago)
- File:
-
- 1 edited
-
trunk/ccl/level-1/l1-sysio.lisp (modified) (8 diffs)
Legend:
- Unmodified
- Added
- Removed
-
trunk/ccl/level-1/l1-sysio.lisp
r5276 r5293 20 20 (octet-pos 0 :type fixnum) ; current io position in octets 21 21 (fileeof 0 :type fixnum) ; file length in elements 22 (input-filter #'false)23 (output-filter #'false)22 (input-filter nil) 23 (output-filter nil) 24 24 (line-termination :unix)) 25 25 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)))) 26 69 27 70 ;;; The file-ioblock-octet-pos field is the (octet) position … … 58 101 (setf (schar string i) #\Return))))) 59 102 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 80 152 "The value of this variable is used when :EXTERNAL-FORMAT is 81 153 unspecified or specified as :DEFAULT. It can meaningfully be given any … … 87 159 is :UNIX.") 88 160 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 94 195 95 196 (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))) 99 198 (when filter 100 (funcall filter ioblock count)) 199 (let* ((buffer (io-buffer-buffer (file-ioblock-outbuf ioblock)))) 200 (funcall filter buffer count))) 101 201 (fd-stream-force-output stream ioblock count finish-p))) 102 202 … … 391 491 392 492 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 401 494 402 495 ;;; This stuff is a lot simpler if we restrict the hair to the … … 450 543 (defun file-stream-advance (stream file-ioblock read-p) 451 544 (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 filter456 (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))) 457 550 n)) 458 551 … … 748 841 (char-p (or (eq element-type 'character) 749 842 (subtypep element-type 'character))) 750 (infer nil)751 843 (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)) 764 849 (class-name (select-stream-class class in-p out-p char-p)) 765 850 (class (find-class class-name)) … … 782 867 class direction)) 783 868 :device fd 869 :encoding encoding 784 870 :external-format real-external-format 785 871 :sharing sharing … … 791 877 (setf (file-ioblock-fileeof ioblock) 792 878 (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) 795 880 (cond ((eq if-exists :append) 796 881 (file-position fstream :end))
Note:
See TracChangeset
for help on using the changeset viewer.
