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

Contents of /zip/acl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.1 - (show annotations)
Sun Apr 3 19:36:28 2005 UTC (9 years ago) by dlichteblau
Branch: MAIN
Branch point for: dlichteblau
Initial revision
1 (in-package :zip)
2
3 (defun octets-to-string (octets ef)
4 (excl:octets-to-string octets :external-format ef))
5
6 (defun string-to-octets (string ef)
7 (excl:string-to-octets octets :external-format ef))
8
9 (defun make-buffer-output-stream (outbuf)
10 (excl:make-buffer-output-stream outbuf))
11
12 (excl:def-stream-class truncating-stream (excl:single-channel-simple-stream)
13 ((size :initarg :size)
14 (pos :initform 0)))
15
16 (defun make-octets (length)
17 (make-array length :element-type '(unsigned-byte 8) :initial-element 0))
18
19 (defmethod excl:device-open ((stream truncating-stream)
20 #+allegro-v7.0 slots
21 options)
22 (declare (ignore options #+allegro-v7.0 slots))
23 (excl:with-stream-class (truncating-stream stream)
24 (setf (slot-value stream 'excl::buffer)
25 (make-octets (excl:device-buffer-length stream)))
26 (excl:add-stream-instance-flags stream :simple :input)
27 (setf (stream-external-format stream) :utf8))
28 t)
29
30 (defmethod excl:device-read
31 ((stream truncating-stream) buffer start end blocking)
32 (unless buffer
33 (setf buffer (slot-value stream 'excl::buffer)))
34 (unless end (setf end (length buffer)))
35 (with-slots (size pos) stream
36 (cond
37 ((eql size pos)
38 -1)
39 (t
40 (setf end (+ start (min (- end start) (- size pos))))
41 (let ((result (call-next-method stream buffer start end blocking)))
42 (unless (minusp result)
43 (incf pos result))
44 result)))))

  ViewVC Help
Powered by ViewVC 1.1.5