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

Contents of /zip/acl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.5 - (show annotations)
Sun Mar 19 14:01:09 2006 UTC (8 years, 1 month ago) by dlichteblau
Branch: MAIN
CVS Tags: HEAD
Changes since 1.4: +5 -1 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 ;;; native implementation of the portable functions in gray.lisp
2
3 (in-package :zip)
4
5 (defun default-external-format ()
6 (excl:find-external-format :default))
7
8 (defun octets-to-string (octets ef)
9 (excl:octets-to-string octets :external-format ef))
10
11 (defun string-to-octets (string ef)
12 (excl:string-to-octets string
13 :external-format ef
14 :null-terminate nil))
15
16 (defun make-buffer-output-stream (outbuf)
17 (excl:make-buffer-output-stream outbuf))
18
19 (excl:def-stream-class truncating-stream (excl:single-channel-simple-stream)
20 ((size :initarg :size)
21 (pos :initform 0)))
22
23 (defun make-octets (length)
24 (make-array length :element-type '(unsigned-byte 8) :initial-element 0))
25
26 (defmethod excl:device-open ((stream truncating-stream)
27 #+(version>= 7 0) slots
28 options)
29 (declare (ignore options #+(version>= 7 0) slots))
30 (excl:with-stream-class (truncating-stream stream)
31 (setf (slot-value stream 'excl::buffer)
32 (make-octets (excl:device-buffer-length stream)))
33 (excl:add-stream-instance-flags stream :simple :input)
34 (setf (stream-external-format stream) :utf8))
35 t)
36
37 (defmethod excl:device-read
38 ((stream truncating-stream) buffer start end blocking)
39 (unless buffer
40 (setf buffer (slot-value stream 'excl::buffer)))
41 (unless end (setf end (length buffer)))
42 (with-slots (size pos) stream
43 (cond
44 ((eql size pos)
45 -1)
46 (t
47 (setf end (+ start (min (- end start) (- size pos))))
48 (let ((result (call-next-method stream buffer start end blocking)))
49 (unless (minusp result)
50 (incf pos result))
51 result)))))

  ViewVC Help
Powered by ViewVC 1.1.5