#! /usr/local/bin/gsi -f
;****************************************************************************
;				TIFF prober
;
; This code reads a TIFF file and prints out its directory (as well as values
; of a few "important" tags)
; Usage
;	tiff-prober tiff-file1...
; $Id: tiff-prober.scm,v 2.0 2003/10/04 02:35:30 oleg Exp oleg $

(include "lib/myenv.scm") ; include target dependent stuff
(include "lib/tiff.scm") ; include target dependent stuff

;---- Endian port
; We need an endian port. The following is Gambit-specific
; Everything that starts with two hashes is Gambit-specific

(define-structure endian-port port msb-first?)

(define (close-endian-port eport)
  (close-input-port (endian-port-port eport)))

; endian-port-set-bigendian! EPORT -> UNSPECIFIED
(define (endian-port-set-bigendian! eport)
  (endian-port-msb-first?-set! eport #t))

;   endian-port-set-littlendian! EPORT -> UNSPECIFIED
(define (endian-port-set-littlendian! eport)
  (endian-port-msb-first?-set! eport #f))

;   endian-port-read-int1:: PORT -> UINTEGER (byte)
(define (endian-port-read-int1 eport)
  (let ((c (read-char (endian-port-port eport))))
    (if (eof-object? c) (error "unexpected EOF")
      (char->integer c))))		; Gambit-specific. Need read-byte

;   endian-port-read-int2:: PORT -> UINTEGER
(define (endian-port-read-int2 eport)
  (let* ((c1 (endian-port-read-int1 eport))
	 (c2 (endian-port-read-int1 eport)))
    (if (endian-port-msb-first? eport)
      (##fixnum.logior (##fixnum.shl c1 8) c2) ;(+ (* c1 256) c2)
      (##fixnum.logior (##fixnum.shl c2 8) c1) ;(+ (* c2 256) c1)
      )))

;   endian-port-read-int4:: PORT -> UINTEGER
(define (endian-port-read-int4 eport)
  (let* ((c1 (endian-port-read-int1 eport))
	 (c2 (endian-port-read-int1 eport))
	 (c3 (endian-port-read-int1 eport))
	 (c4 (endian-port-read-int1 eport)))
    (if (endian-port-msb-first? eport)
      (if (< c1 64)			; The int4 will fit into a fixnum
	(##fixnum.logior
	  (##fixnum.shl
	    (##fixnum.logior
	      (##fixnum.shl
		(##fixnum.logior (##fixnum.shl c1 8) c2) 8) c3) 8) c4)
	(+ (* 256			; The multiplication will make a bignum
	     (##fixnum.logior
	       (##fixnum.shl
		 (##fixnum.logior (##fixnum.shl c1 8) c2) 8) c3))
	  c4))
      ; c4 is the most-significant byte
      (if (< c4 64)
	(##fixnum.logior
	  (##fixnum.shl
	    (##fixnum.logior
	      (##fixnum.shl
		(##fixnum.logior (##fixnum.shl c4 8) c3) 8) c2) 8) c1)
	(+ (* 256
	     (##fixnum.logior
	       (##fixnum.shl
		 (##fixnum.logior (##fixnum.shl c4 8) c3) 8) c2))
	  c1)))))

;   endian-port-setpos PORT INTEGER -> UNSPECIFIED
(define (endian-port-setpos eport pos)
  (OS:fseek-abs (endian-port-port eport) pos))

;^^^^^^^^^^^^^


(let
  ((help
    (lambda ()
      (cerr nl nl "print information about TIFF file(s)" nl)
      (cerr nl "Usage")
      (cerr nl "       tiff-prober tiff-file1...")
      (cerr nl nl "Example:")
      (cerr nl "       tiff-prober im1.tiff im2.tiff" nl nl)
      (exit)))
    (argv-s (argv))
   )
  			; (car argv-s) is program's name, as usual
  (if (or (null? argv-s) (null? (cdr argv-s)))
    (help))		; at least one argument, besides argv[0], is expected
  (for-each
    (lambda (file-name)
      (cout nl nl "Analyzing TIFF file " file-name "..." nl)
      (let* ((eport (make-endian-port (open-input-file file-name) #t))
	     (tiff-dict (read-tiff-file eport))
	      (not-spec (lambda () "*NOT SPECIFIED*")))
        (print-tiff-directory tiff-dict (current-output-port))
        (cout nl "image width:    "
	  (tiff-directory-get tiff-dict 'TIFFTAG:IMAGEWIDTH not-spec))
        (cout nl "image height:   "
	  (tiff-directory-get tiff-dict 'TIFFTAG:IMAGELENGTH not-spec))
        (cout nl "image depth:    "
	  (tiff-directory-get tiff-dict 'TIFFTAG:BITSPERSAMPLE not-spec))
        (cout nl "document name:  "
	  (tiff-directory-get tiff-dict 'TIFFTAG:DOCUMENTNAME not-spec))
        (cout nl "image description: " nl "  "
	  (tiff-directory-get tiff-dict 'TIFFTAG:IMAGEDESCRIPTION not-spec))
        (cout nl "time stamp:     "
	  (tiff-directory-get tiff-dict 'TIFFTAG:DATETIME not-spec))
        (cout nl "compression:    "
	  (tiff-directory-get-as-symbol tiff-dict
	    'TIFFTAG:COMPRESSION not-spec))
        (cout nl nl)))
    (cdr argv-s)))