1: ;;
    2: ;; test for serializer
    3: ;;
    4: 
    5: (use gauche.serializer)
    6: (use gauche.serializer.aserializer)
    7: (use gauche.test)
    8: 
    9: (test-start "serializer")
   10: 
   11: ;; utilities
   12: (define (topological-equal? a b)
   13:   (let ((ctx (make-hash-table)))
   14: 
   15:     (define (tequal? a b)
   16:       (cond ((or (boolean? a) (char? a) (number? a))
   17:              (eqv? a b))
   18:             ((eq? a '()) (eq? b '()))
   19:             ((hash-table-get ctx a #f)   ;node has been appeared
   20:              => (lambda (bb) (eq? bb b)))
   21:             (else
   22:              (hash-table-put! ctx a b)
   23:              (cond ((pair? a) (and (pair? b)
   24:                                    (tequal? (car a) (car b))
   25:                                    (tequal? (cdr a) (cdr b))))
   26:                    ((string? a) (and (string? b) (string=? a b)))
   27:                    ((symbol? a) (and (symbol? b)
   28:                                      (string=? (symbol->string a)
   29:                                                (symbol->string b))))
   30:                    ((keyword? a) (eqv? a b))
   31:                    ((vector? a) (vector-tequal? a b))
   32:                    ((is-a? a <object>) (object-equal? a b))
   33:                    ))))
   34: 
   35:     (define (vector-tequal? a b)
   36:       (and (vector? b)
   37:            (let loop ((la (vector->list a)) (lb (vector->list b)))
   38:              (cond ((null? la) (null? lb))
   39:                    ((null? lb) #f)
   40:                    ((tequal? (car la) (car lb)) (loop (cdr la) (cdr lb)))
   41:                    (else #f)))))
   42: 
   43:     (define (hash-tequal? a b)
   44:       (and (hash-table? b)
   45:            (let loop ((la (hash-table->list a))
   46:                       (lb (hash-table->list b)))
   47:              (cond ((null? a) (null? b))
   48:                    ((null? b) #f)
   49:                    (else (let ((p (assq (caar la) lb)))
   50:                            (and p
   51:                                 (tequal? (cdar la) (cdr p))
   52:                                 (loop (cdr la)
   53:                                       (remove-assq (caar la) lb)))))))))
   54:     (define (object-equal? a b)
   55:       (and (is-a? b <object>)
   56:            (eq? (class-of a) (class-of b))
   57:            (let loop ((slots (get-serializable-slots a)))
   58:              (cond ((null? slots) #t)
   59:                    ((tequal? (slot-ref a (car slots))
   60:                              (slot-ref b (car slots)))
   61:                     (loop (cdr slots)))
   62:                    (else #f)))))
   63: 
   64:     (define (remove-assq elt assoc)
   65:       (let loop ((assoc assoc))
   66:         (cond ((null? assoc) '())
   67:               ((eq? elt (caar assoc)) (remove-assq elt (cdr assoc)))
   68:               (else (cons (car assoc) (remove-assq elt (cdr assoc)))))))
   69: 
   70:     (tequal? a b)
   71:     ))
   72: 
   73: (define (objects->string . objs)
   74:   (call-with-output-string
   75:    (lambda (port)
   76:      (let ((ser (make <aserializer> :port port)))
   77:        (for-each (lambda (item) (write-to-serializer ser item))
   78:                  objs)))))
   79: 
   80: (define (string->objects str)
   81:   (call-with-input-string
   82:    str
   83:    (lambda (port)
   84:      (let ((ser (make <aserializer> :port port)))
   85:        (let loop ((elt (read-from-serializer ser))
   86:                   (data '()))
   87:          (if (eof-object? elt)
   88:              (reverse data)
   89:              (loop (read-from-serializer ser)
   90:                    (cons elt data))))))))
   91: 
   92: ;;----------------------------------------------------------------------
   93: (test-section "aserializer")
   94: 
   95: (define *primitive-types*
   96:    '(1 -1                               ; smallint
   97: ;     999999999999999 -888888888888888   ; bignum
   98:      3.14178 5.0e33                     ; flonum
   99:      #f #t                              ; boolean
  100:      #\null #\return #\A                ; char
  101:      ()                                 ; emptylist
  102:      "string" ""                        ; string
  103:      x y z                              ; symbol
  104:      :key-word                          ; keyword
  105:      (1 2 . 3)                          ; list
  106:      #(a b c)                           ; vector
  107:      )
  108:    )
  109: 
  110: (define *shared-substructure*           ; don't print this!
  111:   (let* ((str "shared string")
  112:          (vec '#(shared vector))
  113:          (circ (list 1 2 3 4))
  114:          (circt (list-tail circ 3)))
  115:     (set-cdr! circt circ)               ;make circ circular
  116:     (list* str vec str vec circ)))
  117: 
  118: (define-class x ()
  119:   ((a :init-keyword :a)
  120:    (b :init-keyword :b)
  121:    (c :init-keyword :c))
  122:   )
  123: 
  124: (define-class y (x)
  125:   ((d :init-keyword :d)
  126:    (e :init-keyword :e))
  127:   )
  128: 
  129: (define *object-instances*
  130:   (let* ((x1 (make x :a 0 :b 1 :c 2))
  131:          (x2 (make x :a 3 :b 4 :c 5))
  132:          (x3 (make x :a '(a b c) :b '(d e f) :c '(x y z)))
  133:          (y1 (make y :a x1 :b x2 :c x3 :d #t :e #f)))
  134:     (list x1 x2 x3 y1)))
  135: 
  136: (test "primitives" *primitive-types*
  137:       (lambda ()
  138:         (let* ((data *primitive-types*)
  139:                (serialized (apply objects->string data)))
  140:           (string->objects serialized))))
  141: 
  142: (test "shared/circular component" #t
  143:       (lambda ()
  144:         (let* ((data *shared-substructure*)
  145:                (serialized (objects->string data))
  146:                (retrieved (car (string->objects serialized))))
  147:           ;;(display serialized)(newline)
  148:           (topological-equal? data retrieved))))
  149: 
  150: (test "objects" #t
  151:       (lambda ()
  152:         (let* ((data *object-instances*)
  153:                (serialized (write-to-string-with-serializer <aserializer> data))
  154:                (retrieved (read-from-string-with-serializer <aserializer> serialized)))
  155:           ;;(map describe data)
  156:           ;;(display serialized)(newline)
  157:           ;;(map describe retrieved)
  158:           (topological-equal? data retrieved))))
  159: 
  160: (test "file i/o" #t
  161:       (lambda ()
  162:         (dynamic-wind
  163:          (lambda () #f)
  164:          (lambda ()
  165:            (let ((data (list *primitive-types*
  166:                              *shared-substructure*
  167:                              *object-instances*)))
  168:              (write-to-file-with-serializer <aserializer> data "test.s")
  169:              (topological-equal? data
  170:                                  (read-from-file-with-serializer <aserializer>
  171:                                                                  "test.s"))
  172:              ))
  173:          (lambda () (sys-remove "test.s"))
  174:          )))
  175: 
  176: ;(test "dserializer"
  177: ;      (lambda ()
  178: ;        (let* ((data *primitive-types*)
  179: ;               (serialized (write-to-string-with-serializer <dserializer> data))
  180: ;               (retrieved (read-from-string-with-serializer <dserializer> serialized))
  181: ;               )
  182: ;          ;;(display serialized)(newline)
  183: ;          (equal? data retrieved))))
  184: 
  185: (test-end)