commit 27e26e49f891db1b5593c33ec4abe498964527c9
parent f1a790c2efb29a7e1a29c04330c52d8e8883f3f0
Author: Tomas Hlavaty <tom@logand.com>
Date: Sat, 10 Aug 2013 19:03:29 +0200
io refactored into cl-rw
Diffstat:
| M | cl-ipp.asd | | | 2 | +- |
| M | ipp.lisp | | | 225 | ++++++++++++++++++++----------------------------------------------------------- |
2 files changed, 58 insertions(+), 169 deletions(-)
diff --git a/cl-ipp.asd b/cl-ipp.asd
@@ -33,6 +33,6 @@
:author "Tomas Hlavaty"
:maintainer "Tomas Hlavaty"
:licence "MIT"
- :depends-on ()
+ :depends-on (:cl-rw)
:serial t
:components ((:file "ipp")))
diff --git a/ipp.lisp b/ipp.lisp
@@ -27,56 +27,6 @@
(in-package :ipp)
-(defvar *input-stream*)
-(defvar *output-stream*)
-
-(defun read-octet ()
- (let ((s *input-stream*))
- (etypecase s
- (stream (read-byte s))
- (function (let ((x (funcall s)))
- (assert (<= 0 x 256))
- x)))))
-
-(defun write-octet (x)
- (assert (<= 0 x #. (1- (expt 2 8))))
- (let ((s *output-stream*))
- (etypecase s
- (stream (write-byte x s))
- (function (funcall s x)))))
-
-(defun read-ushort ()
- (logior (ash (read-octet) 8) (read-octet)))
-
-(defun write-ushort (x)
- (assert (<= 0 x #.(1- (expt 2 16))))
- (write-octet (ash x -8))
- (write-octet (logand #xff x)))
-
-(defun read-dword ()
- (logior (ash (read-ushort) 16) (read-ushort)))
-
-(defun write-dword (x)
- (assert (<= 0 x #.(1- (expt 2 32))))
- (write-ushort (ash x -16))
- (write-ushort (logand #xffff x)))
-
-(defun copy-stream ()
- (when *input-stream*
- (handler-case (loop (write-octet (read-octet)))
- (end-of-file ()))))
-
-(defun read-octets (n)
- (let ((x (make-array n :element-type '(unsigned-byte 8) :initial-element 0)))
- (read-sequence x *input-stream*)
- x))
-
-(defun write-octets (x)
- (etypecase x
- (stream (let ((*input-stream* x)) (copy-stream)))
- (list (mapc 'write-octet x))
- (vector (map 'vector 'write-octet x))))
-
(defun string-to-octets (x) ;; TODO encoding
(ccl:encode-string-to-octets x))
@@ -138,8 +88,8 @@
;;(attribute-name :attributes-charset)
-(defun read-attribute ()
- (let ((tag (read-octet)))
+(defun read-attribute (reader)
+ (let ((tag (rw:next-u8 reader)))
(if (member tag (mapcar 'tag ;; TODO optimize
'(:operation-attributes-tag
:job-attributes-tag
@@ -147,47 +97,49 @@
:printer-attributes-tag
:unsupported-attributes-tag)))
tag
- `(,tag ;;(tag (attribute-tag k))
- ,(octets-to-string (read-octets (read-ushort)))
- , (case tag ;; TODO handle more cases
- ((33 35)
- (assert (= 4 (read-ushort)))
- (read-dword))
- (t (octets-to-string (read-octets (read-ushort)))))))))
-
-(defun read-groups ()
+ (flet ((text ()
+ (octets-to-string
+ (rw:next-octets reader (rw:next-u16 reader)))))
+ `(,tag ;;(tag (attribute-tag k))
+ ,(text)
+ , (case tag ;; TODO handle more cases
+ ((33 35)
+ (assert (= 4 (rw:next-u16 reader)))
+ (rw:next-u32 reader))
+ (t (text))))))))
+
+(defun read-groups (reader)
(let ((sentinel (tag :end-of-attributes-tag)) ;; TODO optimize
- (x (read-octet)))
+ (x (rw:next-u8 reader)))
(loop
until (= sentinel x)
collect `(,x
,@(loop
- while (consp (setq x (read-attribute)))
+ while (consp (setq x (read-attribute reader)))
collect x)))))
#+nil
-(with-open-file (*input-stream* "response.dat" :element-type '(unsigned-byte 8))
- (read-ipp 314))
+(with-open-file (s "response.dat" :element-type '(unsigned-byte 8))
+ (read-ipp (rw:byte-reader s) 314))
-(defun write-group (group)
+(defun write-group (writer group)
(destructuring-bind (group-id &rest plist) group
(when (loop
for (k v) on plist by #'cddr
when v
do (return t))
- (write-octet group-id)
+ (rw:write-u8 writer group-id)
(loop
for (k v) on plist by #'cddr
when v
do (let ((%k (string-to-octets (attribute-name k)))
(%v (string-to-octets v)))
;; TODO additional value (when v is list)
- (write-octet (tag (attribute-tag k)))
- (write-ushort (length %k))
- (write-octets %k)
- (write-ushort (length %v))
- (write-octets %v))))))
-
+ (rw:write-u8 writer (tag (attribute-tag k)))
+ (rw:write-u16 writer (length %k))
+ (rw:write-octets writer %k)
+ (rw:write-u16 writer (length %v))
+ (rw:write-octets writer %v))))))
(defun operation-code (operation)
(cdr (assoc operation '((:print-job 1 0 #x0002)
@@ -233,43 +185,44 @@
;;(operation-code :print-job)
-(defun write-ipp (data-file request-id operation groups)
+(defun write-ipp (writer data-file request-id operation groups)
(destructuring-bind (major minor code) (operation-code operation)
- (write-octet major)
- (write-octet minor)
- (write-ushort code)
- (write-dword request-id)
- (mapc 'write-group groups)
- (write-octet (tag :end-of-attributes-tag))
+ (rw:write-u8 writer major)
+ (rw:write-u8 writer minor)
+ (rw:write-u16 writer code)
+ (rw:write-u32 writer request-id)
+ (dolist (i groups)
+ (write-group writer i))
+ (rw:write-u8 writer (tag :end-of-attributes-tag))
(when data-file
- (with-open-file (*input-stream* data-file :element-type '(unsigned-byte 8))
- (copy-stream)))))
+ (with-open-file (s data-file :element-type '(unsigned-byte 8))
+ (rw:copy (rw:byte-reader s) writer)))))
-(defun read-ipp (request-id)
+(defun read-ipp (reader request-id)
`(:ipp-response
- :major ,(read-octet)
- :minor ,(read-octet)
- :code ,(read-ushort)
- :request-id , (let ((x (read-dword)))
+ :major ,(rw:next-u8 reader)
+ :minor ,(rw:next-u8 reader)
+ :code ,(rw:next-u16 reader)
+ :request-id , (let ((x (rw:next-u32 reader)))
(assert (= x request-id))
x)
- :groups ,(read-groups)))
+ :groups ,(read-groups reader)))
#+nil
-(with-open-file (*input-stream* "response.dat" :element-type '(unsigned-byte 8))
- (read-ipp 314))
+(with-open-file (s "response.dat" :element-type '(unsigned-byte 8))
+ (read-ipp (rw:byte-reader s) 314))
(defun ipp (ipp-client printer-uri request-file response-file
data-file request-id operation groups)
- (with-open-file (*output-stream* request-file
- :element-type '(unsigned-byte 8)
- :direction :output
- :if-exists :supersede
- :if-does-not-exist :create)
- (write-ipp data-file request-id operation groups))
+ (with-open-file (s request-file
+ :element-type '(unsigned-byte 8)
+ :direction :output
+ :if-exists :supersede
+ :if-does-not-exist :create)
+ (write-ipp (rw:byte-writer s) data-file request-id operation groups))
(funcall ipp-client "application/ipp" printer-uri request-file response-file)
- (with-open-file (*input-stream* response-file :element-type '(unsigned-byte 8))
- (read-ipp request-id)))
+ (with-open-file (s response-file :element-type '(unsigned-byte 8))
+ (read-ipp (rw:byte-reader s) request-id)))
(defun print-job (ipp-client
printer-uri
@@ -313,92 +266,28 @@
:job-impressions ,job-impressions
:job-media-sheets ,job-media-sheets))))
-(defun stream (x &optional (start 0))
- (etypecase x
- (list
- (dotimes (i start)
- (pop x))
- (lambda ()
- (pop x)))
- (vector
- (let ((i start)
- (n (length x)))
- (lambda ()
- (when (< i n)
- (prog1 (aref x i)
- (incf i))))))))
-
-(defun char-stream (x &optional (start 0))
- (dotimes (i start)
- (read-char x nil nil))
- (lambda ()
- (read-char x nil nil)))
-
-(defun byte-stream (x &optional (start 0))
- (dotimes (i start)
- (read-byte x nil nil))
- (lambda ()
- (read-byte x nil nil)))
-
-(defun next (stream)
- (funcall stream))
-
-(defun peek (stream)
- (funcall stream 'peek))
-
-(defun peek-stream (stream)
- (let (x)
- (lambda (&optional msg)
- (ecase msg
- (peek (or x (setq x (next stream))))
- ((nil) (prog1 (if x x (next stream))
- (setq x nil)))))))
-
-(defun till (stream &optional markers)
- (let (x)
- (loop
- until (member (setq x (next stream)) (or markers '(nil)))
- collect x)))
-
-;;(till (stream '(0 1 2 3 4) 1) '(3))
-;;(till (stream #(0 1 2 3 4) 1) '(3))
-;;(with-open-file (s "printers.html") (till (char-stream s) '(#\>)))
-
-(defun search-stream (stream needle)
- (let ((all (till stream)) ;; TODO optimize? use kmp algorithm
- (start 0))
- (lambda ()
- (let ((i (search needle all :start2 start)))
- (when i
- (setq start (1+ i))
- (values i all))))))
-
-#+nil
-(with-open-file (s "printers.html")
- (till (search-stream (char-stream s) '#.(coerce "/printers/" 'list))))
-
-(defun printer-search-stream (stream)
+(defun printer-search-reader (reader)
(let* ((k '#.(coerce "\"/printers/" 'list)) ;; TODO #\' as attribute quote
(n (length k))
- (s (search-stream stream k)))
+ (s (rw:search-reader reader k)))
(lambda ()
(block found
(loop
(multiple-value-bind (i all) (funcall s)
(unless i
- (return-from found))
- (let ((z (till (stream all (+ i n)) '(#\"))))
+ (return-from found nil))
+ (let ((z (rw:till (rw:reader all (+ i n)) '(#\"))))
(when (and z (char/= #\? (car z)))
(return-from found (coerce z 'string))))))))))
#+nil
(with-open-file (s "printers.html")
- (till (printer-search-stream (char-stream s))))
+ (rw:till (printer-search-reader (rw:char-reader s))))
(defun list-printers (ipp-client printer-uri response-file)
(funcall ipp-client nil printer-uri nil response-file)
(with-open-file (s response-file)
- (till (printer-search-stream (char-stream s)))))
+ (rw:till (printer-search-reader (rw:char-reader s)))))
(defpackage :ipp.wget
(:use :cl)
