;; ;; Copyright (c) 2006, 2007, John P. T. Moore ;; All rights reserved. ;; ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are met: ;; ;; 1. Redistributions of source code must retain the above copyright notice, ;; this list of conditions and the following disclaimer. ;; ;; 2. Redistributions in binary form must reproduce the above copyright notice, ;; this list of conditions and the following disclaimer in the documentation ;; and/or other materials provided with the distribution. ;; ;; 3. Neither the name of the author nor the names of its contributors may be ;; used to endorse or promote products derived from this software ;; without specific prior written permission. ;; ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" ;; AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE ;; IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ;; ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE ;; LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR ;; CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF ;; SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS ;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN ;; CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ;; ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE ;; POSSIBILITY OF SUCH DAMAGE. ;; (module packedobjects (packedobjects po:version po:subtree) (import scheme chicken foreign) (use lolevel extras srfi-1 srfi-13) ;; foreign includes (foreign-declare "#include \"superapi.h\"") (foreign-declare "#include ") ;; foreign types (define-foreign-type packed-encode "packedEncode") (define-foreign-type packed-decode "packedDecode") (define-syntax first-string (syntax-rules () ((_ s) (string-ref s 0)))) (define-syntax rest-string (syntax-rules () ((_ s) (string-drop s 1)))) (include "chicken-encode.scm") (include "chicken-decode.scm") (include "constraints.scm") ;; foreign functions (define c-write-data (foreign-lambda integer "write" integer c-pointer integer)) (define c-write-message (foreign-lambda integer "writeMessage" integer c-pointer integer)) (define c-read-data (foreign-lambda integer "read" integer c-pointer integer)) (define c-read-message (foreign-lambda integer "readMessage" integer c-pointer integer)) (define c-initialize-encode (foreign-lambda (c-pointer packed-encode) "initializeEncode" c-pointer integer)) (define c-finalize-encode (foreign-lambda int "finalizeEncode" (c-pointer packed-encode))) (define c-initialize-decode (foreign-lambda (c-pointer packed-decode) "initializeDecode" c-pointer)) (define c-finalize-decode (foreign-lambda void "finalizeDecode" (c-pointer packed-decode))) (define c-dump-buffer (foreign-lambda void "dumpBuffer" c-string c-pointer integer)) ;;; end of foreign interface ;; returns part of tree according to search path or #f path not found (define (po:subtree tree path) (let loop ((t tree) (p (cdr path))) (if (null? p) t (loop (assq (car p) (cddr t)) (cdr p))))) ;; convenience macro (define-syntax list-position (syntax-rules () ((_ alis atom) (list-index (lambda (_x) (eq? _x atom)) alis)))) ;; extra information the encode procedure requires about some types (define (make-metadata protocol path values) (let ((t (po:subtree protocol path))) (if t (let ((dt (cadr t))) (case dt ;; simple types ('integer t) ('string t) ('boolean t) ('enumerated t) ('null t) ('octet-string t) ('bit-string t) ('hex-string t) ('numeric-string t) ;; complex types ('sequence (list (car t) dt)) ('sequence-of (list (car t) dt (length (cdr values)))) ('choice (let* ((l (map (lambda (x) (car x)) (cddr t))) (v (caadr values)) (index (list-position l v))) (if index (list (car t) dt (append '(range 1) (list (length l))) (add1 index)) (error "choice failed" v)))) ('set (let* ((items (cddr t)) (s (make-string (length items) #\1)) (l1 (map (lambda (x) (car x)) items)) (l2 (map (lambda (x) (car x)) (cdr values))) (d1 (lset-difference eq? l1 l2)) ;; difference in terms of position (d2 (map (lambda (x) (list-position l1 x)) d1))) (for-each (lambda (x) (string-set! s x #\0)) d2) (list (car t) dt (append '(order-by) l1) s))) (else (error "invalid datatype" dt)))) (error "lookup failed" path)))) (define (add-metadata protocol values) (let loop ((tree values) (parent '())) (cond ((null? tree) '()) ((not (pair? tree)) tree) ((symbol? (car tree)) (let* ((path (append parent (list (car tree)))) (metadata (make-metadata protocol path tree)) (type (cadr metadata))) (if (memq type '(sequence choice null sequence-of set)) (cons metadata (loop (cdr tree) path)) ;; used for types that have a value (cons metadata (cons (cadr tree) ;; the value (loop (cddr tree) path)))))) (else (cons (loop (car tree) parent) (loop (cdr tree) parent)))))) ;;; (define po:version "0.76") (define (packedobjects protocol #!key (pdusize 5000) (strsize 1000)) (define pdu-buf (allocate pdusize)) (if (null-pointer? pdu-buf) (error "malloc failed for" pdusize)) (define str-buf (make-string strsize)) (define (pack-pdu values) (let ((kernel (c-initialize-encode pdu-buf pdusize))) (po:encode (add-metadata protocol values) kernel) (c-finalize-encode kernel))) (define (unpack-pdu) (let* ((kernel (c-initialize-decode pdu-buf)) (tree (po:decode protocol kernel str-buf))) (c-finalize-decode kernel) tree)) (define (self msg . args) (case msg ('pack (pack-pdu (car args))) ('unpack (unpack-pdu)) ('free (unless (null-pointer? pdu-buf) (free pdu-buf) (set! pdu-buf (null-pointer)))) ('dump-buffer (c-dump-buffer (car args) pdu-buf (cadr args))) ('write (c-write-data (car args) pdu-buf (cadr args))) ('write-message (c-write-message (car args) pdu-buf (cadr args))) ('read (c-read-data (car args) pdu-buf (cadr args))) ('read-message (c-read-message (car args) pdu-buf pdusize)) ('meta (pp (add-metadata protocol (car args)))) (else (error "invalid msg")))) ;; automatically free the pdu buffer if necessary (set-finalizer! pdu-buf (lambda (void) (self 'free))) ;; return self self) )