/[zip]/zip/gray.lisp
ViewVC logotype

Contents of /zip/gray.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (hide annotations)
Sun Mar 19 14:01:09 2006 UTC (8 years, 1 month ago) by dlichteblau
Branch: MAIN
Changes since 1.4: +27 -9 lines
     <p>
+      2006-xx-yy: Fixed the gray stream port (including a data
+      corruption bug that was in CVS for some time).  Switched to
+      flexi-stream external-format functions for portability.  Uses
+      trivial-gray-streams now.  Allegro 8.0 fix.  Incompatible change:
+      Don't bind <tt>*locale*</tt> on Allegro anymore.  (Thanks to all
+      patch submitters).
+    <p>
1 dlichteblau 1.1 (in-package :zip)
2    
3 dlichteblau 1.5 (defun default-external-format ()
4     :utf-8)
5    
6     (defun octets-to-string (octets ef)
7     (with-output-to-string (out)
8     (flexi-streams:with-input-from-sequence (in octets)
9     (let ((in* (flexi-streams:make-flexi-stream in :external-format ef)))
10     (loop
11     for c = (read-char in* nil nil)
12     while c
13     do (write-char c out))))))
14    
15     (defun string-to-octets (string ef)
16     (flexi-streams:with-output-to-sequence (out)
17     (with-input-from-string (in string)
18     (let ((out* (flexi-streams:make-flexi-stream out :external-format ef)))
19     (loop
20     for c = (read-char in nil nil)
21     while c
22     do (write-char c out*))))))
23    
24 dlichteblau 1.1 (defclass buffer-output-stream (fundamental-binary-output-stream)
25     ((buf :initarg :buf :accessor buf)
26     (pos :initform 0 :accessor pos)))
27    
28     (defmethod stream-write-sequence
29 dlichteblau 1.5 ((stream buffer-output-stream) seq start end &key)
30     (replace (buf stream)
31     seq
32 dlichteblau 1.1 :start1 (pos stream)
33     :start2 start
34 dlichteblau 1.4 :end2 end)
35     (incf (pos stream) (- end start))
36     seq)
37 dlichteblau 1.1
38     (defun make-buffer-output-stream (outbuf)
39     (make-instance 'buffer-output-stream :buf outbuf))
40    
41 dlichteblau 1.5 (defclass truncating-stream
42     (trivial-gray-stream-mixin fundamental-binary-input-stream)
43 dlichteblau 1.1 ((input-handle :initarg :input-handle :accessor input-handle)
44     (size :initarg :size :accessor size)
45     (pos :initform 0 :accessor pos)))
46    
47     (defmethod stream-read-byte ((s truncating-stream))
48     (if (< (pos s) (size s))
49     (prog1
50     (read-byte (input-handle s))
51     (incf (pos s)))
52     nil))
53    
54 dlichteblau 1.5 (defmethod stream-read-sequence ((s truncating-stream) seq start end &key)
55 dlichteblau 1.1 (let* ((n (- end start))
56     (max (- (size s) (pos s)))
57     (result
58     (read-sequence (input-handle s)
59     seq
60     :start start
61     :end (+ start (min n max)))))
62     (incf (pos s) (- result start))
63     result))

  ViewVC Help
Powered by ViewVC 1.1.5