;;;; Copyright 2005 Juri Pakaste
;;;; 
;;;; This file is part of Lukutoukka.
;;;; 
;;;; Lukutoukka is free software; you can redistribute it and/or modify
;;;; it under the terms of the GNU General Public License as published by
;;;; the Free Software Foundation; either version 2 of the License, or
;;;; (at your option) any later version.
;;;; 
;;;; Lukutoukka is distributed in the hope that it will be useful,
;;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;;; GNU General Public License for more details.
;;;; 
;;;; You should have received a copy of the GNU General Public License
;;;; along with Lukutoukka; if not, write to the Free Software
;;;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA

(define-module (binaryformat-test)
  #:use-module (lukutoukkalib binaryformat)
  #:use-module (lukutoukkalib srfi srfi-56)
  #:use-module (unit-test)
  #:use-module (oop goops)
  #:export (create-test-suite))

(define-class <binaryformat-test> (<test-case>))

(define-method (test-write-empty-packer-procedure (test-case <binaryformat-test>))
  (assert-true (procedure? (create-packer ""))))

(define-method (test-write-empty-packer-with-args (test-case <binaryformat-test>))
  (catch 'wrong-number-of-arguments
         (lambda () 
           ((create-packer "") 12)
           (throw 'test-failed-exception "didn't get an exception"))
         (lambda (key . args) #f)))

(define-method (test-write-empty-packer-result (test-case <binaryformat-test>))
  (assert-equal "" (with-output-to-string (lambda () ((create-packer ""))))))

(define-method (test-write-character-packer-result (test-case <binaryformat-test>))
  (assert-equal "a" (with-output-to-string 
                     (lambda () ((create-packer "c") #\a)))))

(define-method (test-write-native-one-uint8 (test-case <binaryformat-test>))
  (assert-equal (with-output-to-string (lambda () (write-binary-uint8 42)))
                (with-output-to-string (lambda ()
                                         ((create-packer "B") 42)))))

(define-method (test-write-network-one-uint16 (test-case <binaryformat-test>))
  (assert-equal (with-output-to-string (lambda () (write-network-uint16 5)))
                (with-output-to-string (lambda ()
                                         ((create-packer "S" 'big-endian) 5)))))

(define-method (test-write-two-sint16 (test-case <binaryformat-test>))
  (assert-equal (with-output-to-string (lambda () 
                                         (write-binary-sint16 4)
                                         (write-binary-sint16 2)))
                (with-output-to-string (lambda ()
                                         ((create-packer "SS") 4 2)))))

(define-method (test-write-native-one-sint8 (test-case <binaryformat-test>))
  (assert-equal (with-output-to-string (lambda () (write-binary-sint8 10)))
                (with-output-to-string (lambda ()
                                         ((create-packer "b") 10)))))

(define-method (test-write-native-one-sint16 (test-case <binaryformat-test>))
  (assert-equal (with-output-to-string (lambda () (write-binary-sint16 100)))
                (with-output-to-string (lambda ()
                                         ((create-packer "s") 100)))))

(define-method (test-read-empty-unpacker (test-case <binaryformat-test>))
  (assert-equal '() ((create-unpacker ""))))

(define-method (test-read-one-uint8 (test-case <binaryformat-test>))
  (let ((s (with-output-to-string (lambda () (write-binary-uint8 10)))))
    (assert-equal (list (with-input-from-string 
                         s (lambda () (read-binary-uint8))))
                  (with-input-from-string 
                   s (lambda () ((create-unpacker "B")))))))

(define-method (test-read-two-sint32 (test-case <binaryformat-test>))
  (let ((s (with-output-to-string
            (lambda ()
              (write-binary-sint32 4294967292)
              (write-binary-sint32 4294967293)))))
    (assert-equal (with-input-from-string s (lambda () 
                                              (list 
                                               (read-binary-sint32) 
                                               (read-binary-sint32))))
                  (with-input-from-string s (lambda ()
                                              ((create-unpacker "ii")))))))

(define-method (test-misread-two-sint32 (test-case <binaryformat-test>))
  (let ((s (with-output-to-string
            (lambda ()
              (write-binary-sint32 (- (expt 2 32) 10))
              (write-binary-sint32 (- (expt 2 32) 11))))))
    (assert-true
     (not (equal?
           (with-input-from-string s (lambda ()
                                       (list
                                        (read-binary-uint32)
                                        (read-binary-uint32))))
           (with-input-from-string s (lambda ()
                                       ((create-unpacker "ii")))))))))

(define-method (test-pack-and-unpack (test-case <binaryformat-test>))
  (define (tn power minus) (- (expt 2 power) minus))
  (let* ((format-string "bBsSiIqQc")
         (format-values (list (tn 8 10)
                              (tn 8 11)
                              (tn 16 10)
                              (tn 16 11)
                              (tn 32 4)
                              (tn 32 2)
                              (tn 64 20)
                              (tn 64 21)
                              #\d))
         (packer (create-packer format-string))
         (unpacker (create-unpacker format-string))
         (formatted-string (with-output-to-string
                            (lambda () (apply packer format-values)))))
    (assert-equal
     (with-input-from-string formatted-string
                             (lambda () (unpacker)))
     (with-input-from-string 
      (with-output-to-string
       (lambda () 
         (apply packer
                (with-input-from-string formatted-string
                                        (lambda () (unpacker))))))
      (lambda () (unpacker))))))
  

(define (create-test-suite) 
  (let ((suite (make <test-suite> #:name "binaryformat-test-suite")))
    (add suite (make <binaryformat-test>))
    suite))