cl-ipp

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

commit a3a415d5c8ebe385989d1bd463efe445f42554fc
parent d4776dd8498cda8ddb31670fdcf471add6b8fd24
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sun, 11 Aug 2013 16:31:05 +0200

cups-get-default and cups-get-printers implemented
- reading improved, group-reader introduced
- writing improved

Diffstat:
Mipp.lisp | 209++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++-----------------
1 file changed, 166 insertions(+), 43 deletions(-)

diff --git a/ipp.lisp b/ipp.lisp @@ -142,9 +142,15 @@ for (k) in attributes collect (cons (string-downcase (symbol-name k)) k)))) (defun attribute-keyword (string) + (cdr (assoc string x :test #'equal)) + #+nil (or (cdr (assoc string x :test #'equal)) (error "unknown IPP attribute ~s" string))))) +#+nil +(with-open-file (s "response2.dat" :element-type '(unsigned-byte 8)) + (read-ipp (rw:byte-reader s) 314)) + ;;(attribute-tag :printer-uri) ;;(attribute-keyword "printer-uri") @@ -154,9 +160,11 @@ ;;(attribute-name :attributes-charset) (defun read-text (reader) - (octets-to-string (rw:next-octets reader (rw:next-u16 reader)))) + (let ((n (rw:next-u16 reader))) + (when (plusp n) + (octets-to-string (rw:next-octets reader n))))) -(defun read-value (reader tag) +(defun read-value (reader tag) ;; TODO signed integers! (ecase tag (:no-value (assert (= 0 (rw:next-u16 reader)))) @@ -165,22 +173,32 @@ (rw:next-u32 reader)) (:boolean (assert (= 1 (rw:next-u16 reader))) - (not (zerop (rw:next-u32 reader)))) - ;; :octetString + (not (zerop (rw:next-u8 reader)))) + (:octetString + (let ((n (rw:next-u16 reader))) + (when (plusp n) + (let ((x (rw:next-octets reader n))) + (assert x) + x)))) (:dateTime (assert (= 11 (rw:next-u16 reader))) - `(:dateTime ,(rw:next-u16 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader) - ,(rw:next-u8 reader))) - ;; :resolution - ;; :rangeOfInteger + (list tag + (rw:next-u16 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader) + (rw:next-u8 reader))) + (:resolution + (assert (= 9 (rw:next-u16 reader))) + (list tag (rw:next-u32 reader) (rw:next-u32 reader) (rw:next-u8 reader))) + (:rangeOfInteger + (assert (= 8 (rw:next-u16 reader))) + (list tag (rw:next-u32 reader) (rw:next-u32 reader))) ((:textWithLanguage :nameWithLanguage :textWithoutLanguage @@ -193,48 +211,99 @@ :mimeMediaType) (read-text reader)))) -(defun read-attribute (reader) - (let ((tag (tag (rw:next-u8 reader)))) - (if (member tag '(:operation-attributes-tag - :job-attributes-tag - :end-of-attributes-tag - :printer-attributes-tag - :unsupported-attributes-tag)) - tag - (list (attribute-keyword (read-text reader)) - (read-value reader tag))))) - -(defun read-groups (reader) - (let ((x (tag (rw:next-u8 reader)))) - (loop - until (eq :end-of-attributes-tag x) - collect `(,x - ,@(loop - while (consp (setq x (read-attribute reader))) - collect x))))) +(defun group-reader (reader) + (let (done tag group-tag attributes attribute) + (lambda () + (unless done + (block found + (flet ((yield () + ;;(print (list :@@@ done tag group-tag attributes attribute)) + (let ((z (when (and group-tag (or attributes attribute)) + (when attribute + (push attribute attributes)) + (cons group-tag (nreverse attributes))))) + (setq group-tag tag attributes nil attribute nil) + (return-from found z)))) + (loop + (setq tag (tag (rw:next-u8 reader))) + ;;(print (list :!!! tag)) + (when (eq :end-of-attributes-tag tag) + (setq done t) + (yield)) + (if (member tag '(:operation-attributes-tag + :job-attributes-tag + ;;:end-of-attributes-tag + :printer-attributes-tag + :unsupported-attributes-tag)) + (if (and group-tag (or attributes attribute)) + (yield) + (setq group-tag tag)) + (let ((k (read-text reader))) + (if k + (progn + (when attribute + (push attribute attributes)) + (setq attribute (list tag + (or (attribute-keyword k) k) + (read-value reader tag)))) + (setq attribute (nconc + attribute + (list (read-value reader tag))))) + #+nil(print (list :%%% attribute))))))))))) #+nil (with-open-file (s "response.dat" :element-type '(unsigned-byte 8)) (read-ipp (rw:byte-reader s) 314)) +#+nil +(with-open-file (s "response2.dat" :element-type '(unsigned-byte 8)) + (read-ipp (rw:byte-reader s) 314)) + (defun write-text (writer x) (let ((y (string-to-octets x))) (rw:write-u16 writer (length y)) (rw:write-octets writer y))) -(defun write-value (writer tag x) +(defun write-value (writer tag x) ;; TODO signed integers! (ecase tag - ;; :no-value + (:no-value + (rw:write-u16 writer 0)) ((:integer :enum) (rw:write-u16 writer 4) (rw:write-u32 writer x)) (:boolean (rw:write-u16 writer 1) (rw:write-u8 writer (if x 1 0))) - ;; :octetString - ;; :dateTime - ;; :resolution - ;; :rangeOfInteger + (:octetString + (rw:write-u16 writer (length x)) + (rw:write-octets writer x)) + (:dateTime + (rw:write-u16 writer 11) + (destructuring-bind (tag2 a b c d e f g h i j) x + (assert (eq tag tag2)) + (rw:write-u16 writer a) + (rw:write-u8 writer b) + (rw:write-u8 writer c) + (rw:write-u8 writer d) + (rw:write-u8 writer e) + (rw:write-u8 writer f) + (rw:write-u8 writer g) + (rw:write-u8 writer h) + (rw:write-u8 writer i) + (rw:write-u8 writer j))) + (:resolution + (rw:write-u16 writer 9) + (destructuring-bind (tag2 a b c) x + (assert (eq tag tag2)) + (rw:write-u32 writer a) + (rw:write-u32 writer b) + (rw:write-u8 writer c))) + (:rangeOfInteger + (rw:write-u16 writer 8) + (destructuring-bind (tag2 a b) x + (assert (eq tag tag2)) + (rw:write-u32 writer a) + (rw:write-u32 writer b))) ((:textWithLanguage :nameWithLanguage :textWithoutLanguage @@ -335,7 +404,7 @@ :request-id , (let ((x (rw:next-u32 reader))) (assert (= x request-id)) x) - :groups ,(read-groups reader))) + :groups ,(rw:till (group-reader reader)))) #+nil (with-open-file (s "response.dat" :element-type '(unsigned-byte 8)) @@ -610,7 +679,47 @@ ;; TODO enable-printer ;; TODO disable-printer ;; TODO cups-get-default -;; TODO cups-get-printers + +(defun cups-get-default (ipp-client + printer-uri + request-file + response-file + request-id + &key + (attributes-charset "utf-8") + (attributes-natural-language "en")) + (ipp ipp-client + printer-uri + request-file + response-file + nil + request-id + :cups-get-default + `((,(tag :operation-attributes-tag) + :attributes-charset ,attributes-charset + :attributes-natural-language ,attributes-natural-language + :printer-uri ,printer-uri)))) + +(defun cups-get-printers (ipp-client + printer-uri + request-file + response-file + request-id + &key + (attributes-charset "utf-8") + (attributes-natural-language "en")) + (ipp ipp-client + printer-uri + request-file + response-file + nil + request-id + :cups-get-printers + `((,(tag :operation-attributes-tag) + :attributes-charset ,attributes-charset + :attributes-natural-language ,attributes-natural-language + :printer-uri ,printer-uri)))) + ;; TODO cups-add-modify-printer ;; TODO cups-delete-printer ;; TODO cups-get-classes @@ -814,6 +923,20 @@ :requested-attributes '(:job-id)) #+nil +(ipp::cups-get-default 'ipp-client + "http://localhost:631/printers/Virtual_PDF_Printer" + "request2.dat" + "response2.dat" + 314) + +#+nil +(ipp::cups-get-printers 'ipp-client + "http://localhost:631/printers/Virtual_PDF_Printer" + "request2.dat" + "response2.dat" + 314) + +#+nil (ipp:list-printers 'ipp-client "http://localhost:631/printers/" "printers.html")