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

Contents of /zip/acl.lisp

Parent Directory Parent Directory | Revision Log Revision Log


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

  ViewVC Help
Powered by ViewVC 1.1.5