cl-ipp

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

commit b637f2779d1bf89abf77307df38f431e8b9f33c2
parent a2dd25809c045da65c80ff9678d642e882126a6b
Author: Tomas Hlavaty <tom@logand.com>
Date:   Sat, 10 Aug 2013 22:25:59 +0200

read|write-value introduced

Diffstat:
Mipp.lisp | 185++++++++++++++++++++++++++++++++++++++++++++++++++++++-------------------------
1 file changed, 127 insertions(+), 58 deletions(-)

diff --git a/ipp.lisp b/ipp.lisp @@ -66,53 +66,87 @@ ;;(tag #x45) ;;(tag :uri) -(defun attribute-tag (attribute) - (cdr (assoc attribute '((:attributes-charset . :charset) - (:attributes-natural-language . :naturalLanguage) - (:printer-uri . :uri) - (:requesting-user-name . :nameWithoutLanguage) - (:job-name . :nameWithoutLanguage) - (:ipp-attribute-fidelity . :boolean) - (:document-name . nil) - (:document-format . nil) - (:document-natural-language . :naturalLanguage) - (:compression . nil) - (:job-k-octets . nil) - (:job-impressions . nil) - (:job-media-sheets . nil))))) +(let ((attributes '((:attributes-charset . :charset) + (:attributes-natural-language . :naturalLanguage) + (:printer-uri . :uri) + (:requesting-user-name . :nameWithoutLanguage) + (:job-name . :nameWithoutLanguage) + (:ipp-attribute-fidelity . :boolean) + (:document-name . nil) + (:document-format . nil) + (:document-natural-language . :naturalLanguage) + (:compression . nil) + (:job-k-octets . nil) + (:job-impressions . nil) + (:job-media-sheets . nil) + (:copies . :integer) + (:sides . :keyword) + (:job-uri . nil) + (:job-id . nil) + (:job-state . nil) + (:job-state-reasons . nil)))) + + (defun attribute-tag (attribute) + (cdr (assoc attribute attributes))) + + (let ((x (loop + for (k) in attributes + collect (cons (string-downcase (symbol-name k)) k)))) + (defun attribute-keyword (string) + (or (cdr (assoc string x :test #'equal)) + (error "unknown attribute ~s" string))))) ;;(attribute-tag :printer-uri) +;;(attribute-keyword "printer-uri") (defun attribute-name (attribute) (format nil "~(~a~)" attribute)) ;;(attribute-name :attributes-charset) +(defun read-text (reader) + (octets-to-string (rw:next-octets reader (rw:next-u16 reader)))) + +(defun read-value (reader tag) + (ecase tag + ;; :no-value + ((:integer :enum) + (assert (= 4 (rw:next-u16 reader))) + (rw:next-u32 reader)) + (:boolean + (assert (= 1 (rw:next-u16 reader))) + (not (zerop (rw:next-u32 reader)))) + ;; :octetString + ;; :dateTime + ;; :resolution + ;; :rangeOfInteger + ((:textWithLanguage + :nameWithLanguage + :textWithoutLanguage + :nameWithoutLanguage + :keyword + :uri + :uriScheme + :charset + :naturalLanguage + :mimeMediaType) + (read-text reader)))) + (defun read-attribute (reader) - (let ((tag (rw:next-u8 reader))) - (if (member tag (mapcar 'tag ;; TODO optimize - '(:operation-attributes-tag - :job-attributes-tag - :end-of-attributes-tag - :printer-attributes-tag - :unsupported-attributes-tag))) + (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 - (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)))))))) + (list (attribute-keyword (read-text reader)) + (read-value reader tag))))) (defun read-groups (reader) - (let ((sentinel (tag :end-of-attributes-tag)) ;; TODO optimize - (x (rw:next-u8 reader))) + (let ((x (tag (rw:next-u8 reader)))) (loop - until (= sentinel x) + until (eq :end-of-attributes-tag x) collect `(,x ,@(loop while (consp (setq x (read-attribute reader))) @@ -122,24 +156,51 @@ (with-open-file (s "response.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) + (ecase tag + ;; :no-value + ((: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 + ((:textWithLanguage + :nameWithLanguage + :textWithoutLanguage + :nameWithoutLanguage + :keyword + :uri + :uriScheme + :charset + :naturalLanguage + :mimeMediaType) + (write-text writer x)))) + (defun write-group (writer group) (destructuring-bind (group-id &rest plist) group (when (loop - for (k v) on plist by #'cddr + for (v) on (cdr plist) by #'cddr when v do (return t)) (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))) + do (let ((tag (attribute-tag k))) ;; TODO additional value (when v is list) - (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)))))) + (rw:write-u8 writer (tag tag)) + (write-text writer (attribute-name k)) + (write-value writer tag v)))))) (defun operation-code (operation) (cdr (assoc operation '((:print-job 1 0 #x0002) @@ -238,14 +299,16 @@ (attributes-natural-language "en") (requesting-user-name (user-name)) job-name - ipp-attribute-fidelity - document-name - document-format - document-natural-language - compression - job-k-octets - job-impressions - job-media-sheets) + (ipp-attribute-fidelity t) + ;; document-name + ;; document-format + ;; document-natural-language + ;; compression + ;; job-k-octets + ;; job-impressions + ;; job-media-sheets + copies + sides) (ipp ipp-client printer-uri request-file @@ -261,13 +324,15 @@ :requesting-user-name ,requesting-user-name :job-name ,job-name :ipp-attribute-fidelity ,ipp-attribute-fidelity - :document-name ,document-name - :document-format ,document-format - :document-natural-language ,document-natural-language - :compression ,compression - :job-k-octets ,job-k-octets - :job-impressions ,job-impressions - :job-media-sheets ,job-media-sheets)))) + ;; :document-name ,document-name + ;; :document-format ,document-format + ;; :document-natural-language ,document-natural-language + ;; :compression ,compression + ;; :job-k-octets ,job-k-octets + ;; :job-impressions ,job-impressions + ;; :job-media-sheets ,job-media-sheets + :copies ,copies + :sides ,sides)))) (defun printer-search-reader (reader) (let* ((k '#.(coerce "\"/printers/" 'list)) ;; TODO #\' as attribute quote @@ -379,7 +444,11 @@ "request2.dat" "response2.dat" "test.txt" - 314) + 314 + :ipp-attribute-fidelity nil + :copies 2 + :sides "two-sided-long-edge" + ) #+nil (ipp:list-printers 'ipp-client