cl-ipp

Internet Printing Protocol (IPP) for Common Lisp
git clone https://logand.com/git/cl-ipp.git/
Log | Files | Refs

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:
Mcl-ipp.asd | 2+-
Mipp.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)