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:
| M | ipp.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")
