(defpackage :exif
  (:use :common-lisp :lisp-binary :lisp-binary-utils))

(in-package :exif)

(declaim (optimize (debug 3) (speed 0)))

(define-enum tiff-type 2 (:byte-order :dynamic)
  (:unsigned-byte 1)
  :ascii
  :unsigned-short
  :unsigned-long
  Two unsigned - longs
  :signed-byte
  :undefined
  :signed-short
  :signed-long
  :signed-rational
  :single-float
  :double-float)

(define-enum tiff-byte-order 2 (:byte-order :little-endian)
  (:little-endian #x4949)
  (:big-endian #x4d4d))

(defvar *pending-buffers* nil)
(defvar *tiff-start* nil)

(defun slot-path (object &rest slots)
  (loop for slot in slots do
       (setf object (slot-value object slot)))
  object)

(defun no-writer (obj stream)
  (declare (ignore obj stream))
  0)

(defun read-rational (type stream)
  (let-values* ((signed (ecase type
			  (:unsigned-rational nil)
			  (:signed-rational t)))
		((numerator numerator-bytes) (read-integer 4 stream :byte-order *byte-order*
							   :signed signed))
		((denominator denominator-bytes) (read-integer 4 stream :byte-order *byte-order*
							      :signed signed)))
    (values (/ numerator denominator)
	    (+ numerator-bytes denominator-bytes))))

(defun write-rational (value type stream)
  (let* ((signed (ecase type
		   (:unsigned-rational nil)
		   (:signed-rational t))))
    (+
     (write-integer (numerator value) 4 stream :byte-order *byte-order*
		    :signed signed)
     (write-integer (denominator value) 4 stream :byte-order *byte-order*
		    :signed signed))))  

(defun ensure-non-null-pointer (pointer-value)
  (assert (/= 0 pointer-value)))

(defun tiff-type->defbinary-type (type)
  (ecase type
    ((:unsigned-long :undefined) '(unsigned-byte 32))
    (:signed-long '(signed-byte 32))
    (:double-float 'double-float)
    (:single-float 'single-float)
    (:ascii '(terminated-string 1))
    ((:signed-rational :unsigned-rational)
     `(custom :reader (lambda (stream)
			(read-rational ,type stream))
	      :writer (lambda (obj stream)
			(write-rational obj ,type stream))))
    (:signed-byte '(signed-byte 8))
    (:unsigned-byte '(unsigned-byte 8))
    (:signed-short '(signed-byte 16))
    (:unsigned-short '(unsigned-byte 16))))

(defbinary directory-entry (:byte-order :dynamic)
  (file-position 0 :type file-position)
  (tag 0 :type (unsigned-byte 16))
  (type 0 :type tiff-type)
  (count 0 :type (unsigned-byte 32)
	 ;; This custom writer ensures that the COUNT remains
	 ;; synced with the length of the VALUE below.
	 :writer (lambda (obj stream)
		   (declare (ignore obj))
		   (setf count (if (eq type :ascii)
				   (1+ (length value))
				   (if (or (listp value)
					   (vectorp value))
				       (length value)
				       1)))
		   (write-integer count 4 stream :byte-order *byte-order*)))
  The VALUE depends on both the TYPE and the COUNT . The total number of
  bytes needed to store the VALUE is given by ( size of the type ) * ( count ) .
  If this size is > 4 bytes , then the type of the VALUE must resolve to :
  ;;
    ( pointer : pointer - type ( unsigned - byte 32 )
  ;;            :data-type the-actual-type-of-the-value
  ;;            :base-pointer 'tiff-base-pointer
  ;;            :region-tag 'tiff-region)
  ;;
  The BASE - POINTER is declared at the beginning of the TIFF type definition ,
  ;; and tells the LISP-BINARY library that the pointer is an offset that
  ;; begins at the BASE-POINTER.
  ;;
  ;; The REGION-TAG is used in writing the pointer. The region tag named
  TIFF - REGION is also declared in the TIFF type definition , and determines
  ;; where the data being pointed to will end up going. The value is merely
  ;; STORED when the pointer is written, and it gets written to disk when the
  ;; REGION-TAG is reached.
  (value 0 :type (eval
		  (cond
  This tells LISP - BINARY that strings with a count < = 4
  ( which includes the terminating NUL ) will fit inside
  the VALUE , so we do n't need a pointer .
		    ((and (eq type :ascii)
			  (<= count 4))
		     (tiff-type->defbinary-type :ascii))
		    ;; This tells LISP-BINARY that byte arrays with
  count < = 4 and short arrays with count < = 2
  will fit within the VALUE .
		    ((or (and (member type '(:signed-byte :unsigned-byte))
			      (<= count 4)
			      (> count 1))
			 (and (member type '(:signed-short :unsigned-short))
			      (= count 2)))
		     `(simple-array ,(tiff-type->defbinary-type type)
				    (,count)))
		    ;; This makes any other array type into a pointer.
		    ((> count 1)
		     `(pointer :pointer-type (unsigned-byte 32)
			       :data-type ,(if (eq type :ascii)
					       (tiff-type->defbinary-type :ascii)
					       `(simple-array ,(tiff-type->defbinary-type type) (,count)))
			       :base-pointer-name 'tiff-base-pointer
			       :validator #'ensure-non-null-pointer
			       :region-tag 'tiff-region))
		    ;; Certain tags mark their value as being an
		    ;; unsigned long, but they should really be treated
  as pointers to Image File Directories .
  EXIF
				   34853       ;; GPS
  Interoperability
		     `(pointer :pointer-type (unsigned-byte 32)
			       :data-type tiff-image-file-directory
			       :base-pointer-name 'tiff-base-pointer
			       :validator #'ensure-non-null-pointer
			       :region-tag 'tiff-region))
		    (t
		     (case type
		       ((:undefined)
			'(unsigned-byte 32))
  Some types are just plain too big to fit in the VALUE .
		       ;; Generate pointers to them.
		       ((:double-float :signed-rational :unsigned-rational :ascii)
			`(pointer :pointer-type (unsigned-byte 32)
				  :data-type ,(tiff-type->defbinary-type type)
				  :base-pointer-name 'tiff-base-pointer
				  :validator #'ensure-non-null-pointer
				  :region-tag 'tiff-region))
		       ;; Some types will fit just fine.
		       (otherwise (tiff-type->defbinary-type type)))))))
  If the VALUE does n't use 32 bits , then it must be padded . The PADDING
  is an unsigned integer that fills in the space not used by the VALUE .
  (padding 0 :type (eval (if (> count 1)
			     'null
			     (ecase type
			       (:ascii
				(if (>= count 4)
				    'null
				    `(unsigned-byte ,(* 8 (- 4 count)))))
			       ((:unsigned-long :unsigned-rational :signed-rational :double-float :signed-long
						:single-float :undefined)
				'null)
			       ((:signed-byte :unsigned-byte)
				'(unsigned-byte 24))
			       ((:signed-short :unsigned-short)
				'(unsigned-byte 16)))))))

(defbinary tiff-image-file-directory
    (:align 2 :byte-order :dynamic)
  (directory-entries #() :type (counted-array 2 directory-entry))
  (next-directory-offset 0 :type (unsigned-byte 32)))

(defun write-integer/debug (&rest arguments)
  (format t "Calling ~S~%" (cons 'write-integer arguments))
  (apply #'write-integer arguments))

(defbinary tiff (:byte-order :dynamic :preserve-*byte-order* nil)
  (tiff-base-pointer 0 :type base-pointer)
  (byte-order 0 :type tiff-byte-order :reader (lambda (stream)
						      (values
						       (setf *byte-order* (read-binary-type 'tiff-byte-order stream))
						       2)))
  (magic 42 :type (magic :actual-type (unsigned-byte 16)
			 :value 42))
  (offset-ptr 0 :type file-position)
  (first-image-file-directory-offset 0 :type (unsigned-byte 32))
  (image-directories nil :type (custom
				:reader (lambda (stream)
					  (let* ((next-directory nil)
						 (byte-count 0)
						 (directories
						  (with-file-position (0 stream)
						    (loop for offset = first-image-file-directory-offset
						       then (slot-value next-directory 'next-directory-offset)
						       until (= offset 0)
						       collect (progn
								 (file-position stream (+ offset tiff-base-pointer))
								 (setf next-directory
								       (multiple-value-bind (dir bytes)
									   (read-binary 'tiff-image-file-directory stream)
									 (incf byte-count bytes)
									 dir)))))))
					    (values directories byte-count)))
				:writer (lambda (obj stream)
					  (declare (ignore obj))
					  (force-output stream)
					  (let ((real-offset (file-length stream)))
					    (with-file-position (offset-ptr stream)
					      (write-integer (- real-offset tiff-base-pointer) 4 stream :byte-order *byte-order*)
					      (setf first-image-file-directory-offset (- real-offset tiff-base-pointer))
					      (file-position stream real-offset)
					      (loop for (dir . more-dirs) on image-directories sum
						   (let ((bytes (write-binary dir stream))
							 (new-eof (file-position stream)))
						     (force-output stream)
						     (file-position stream (- new-eof 4))
						     (write-integer (if more-dirs
									(- new-eof tiff-base-pointer)
									0) 4 stream :byte-order *byte-order*)
						     bytes)))))))
  (tiff-region 0 :type (region-tag :base-pointer-name 'tiff-base-pointer)))
				    

(defbinary jpeg-generic-tag (:byte-order :big-endian)
  (offset 0 :type file-position)
  (magic #xff :type (magic :actual-type (unsigned-byte 8)
			   :value #xff))
  (code 0 :type (unsigned-byte 8))
  (length-offset 0 :type file-position)
  (length 0 :type (eval
		   (case code
		     ((#xd8 #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7
			    #xd9 #xdd)
		      'null)
		     (otherwise
		      '(unsigned-byte 16)))))
  (restart-interval nil :type (eval
			       (if (= code #xdd)
				   '(unsigned-byte 32)
				   'null))))

(defvar *exif-header* #x457869660000)

(defbinary jpeg-app1-body (:byte-order :big-endian)
  (exif-header 0 :type (unsigned-byte 48))
  (body nil :type (eval (if (= exif-header *exif-header*)
			    'tiff
			    'null))))

(defun jpeg-tag-no-length-p (tag)
  (or (member (slot-value tag 'code)
	      '(#xd8 #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7
		#xd9 #xdd))
      (not (slot-value tag 'length))))


(defbinary jpeg-generic-segment (:byte-order :big-endian)
  (file-position 0 :type file-position)
  (tag nil :type jpeg-generic-tag)
  (contents nil :type (eval
		       (cond ((= (slot-value tag 'code) 225)
			      'jpeg-app1-body)
			     ((null (slot-value tag 'length))
			      'null)
			     (t `(simple-array (unsigned-byte 8) (,(- (slot-value tag 'length) 2)))))))
  (buffer nil :type (eval
		     (if (or (and (jpeg-app1-body-p contents)
				  (tiff-p (slot-value contents 'body)))
			     (jpeg-tag-no-length-p tag))
			 'null
			 `(simple-array (unsigned-byte 8) (,(- (slot-value tag 'length) 8))))))
  (file-positioner nil :type (custom :reader
				     (lambda (stream)
				       (values
					(and (not (jpeg-tag-no-length-p tag))
					     (file-position stream
							    (+ (slot-value tag 'length-offset)
							       (slot-value tag 'length))))
					0))
				     :writer
				     (lambda (obj stream)
				       (declare (ignore obj))
					 (if (jpeg-tag-no-length-p tag)
					     (let ((end-position (file-position stream)))
					       (with-file-position ((slot-value tag 'length-offset) stream)
						 (write-integer (- end-position (slot-value tag 'length-offset))
								2 stream :byte-order :big-endian)))
					   0)))))
							    

(defun read-rest-of-stream (stream)
  (read-bytes (- (file-length stream)
		 (file-position stream))
	      stream))


(defun remove-exif-data (input-file output-file)
  (with-open-binary-file (in input-file)
    (let ((jpeg-segments (loop for segment = (read-binary 'jpeg-generic-segment in)
			    until (= (slot-value
				      (slot-value segment 'tag) 'code) 225)
			    collect segment))
	  (rest-of-image (read-rest-of-stream in)))
      (with-open-binary-file (out output-file
				  :direction :io
				  :if-exists :supersede
				  :if-does-not-exist :create)
	(loop for segment in jpeg-segments
	   do (write-binary segment out))
	(write-bytes rest-of-image out)))))

(defun read/write-test (pathname object type &key (base-pointer 0) tags)
  (with-local-pointer-resolving-context
    (with-open-binary-file (out pathname
				:direction :io
				:if-exists :supersede
				:if-does-not-exist :create)
      (write-binary-type object
			 type out)
      (loop for tag in tags
	 do (lisp-binary::dump-tag tag base-pointer out)))
    (with-open-binary-file (in pathname
			       :direction :input)
      (read-binary-type type in))))

 This custom writer ensures that the COUNT remains
 synced with the length of the VALUE below.

            :data-type the-actual-type-of-the-value
            :base-pointer 'tiff-base-pointer
            :region-tag 'tiff-region)

 and tells the LISP-BINARY library that the pointer is an offset that
 begins at the BASE-POINTER.

 The REGION-TAG is used in writing the pointer. The region tag named
 where the data being pointed to will end up going. The value is merely
 STORED when the pointer is written, and it gets written to disk when the
 REGION-TAG is reached.
 This tells LISP-BINARY that byte arrays with
 This makes any other array type into a pointer.
 Certain tags mark their value as being an
 unsigned long, but they should really be treated
 GPS
 Generate pointers to them.
 Some types will fit just fine.
(defpackage :exif
  (:use :common-lisp :lisp-binary :lisp-binary-utils))

(in-package :exif)

(declaim (optimize (debug 3) (speed 0)))

(define-enum tiff-type 2 (:byte-order :dynamic)
  (:unsigned-byte 1)
  :ascii
  :unsigned-short
  :unsigned-long
  Two unsigned - longs
  :signed-byte
  :undefined
  :signed-short
  :signed-long
  :signed-rational
  :single-float
  :double-float)

(define-enum tiff-byte-order 2 (:byte-order :little-endian)
  (:little-endian #x4949)
  (:big-endian #x4d4d))

(defvar *pending-buffers* nil)
(defvar *tiff-start* nil)

(defun slot-path (object &rest slots)
  (loop for slot in slots do
       (setf object (slot-value object slot)))
  object)

(defun no-writer (obj stream)
  (declare (ignore obj stream))
  0)

(defun read-rational (type stream)
  (let-values* ((signed (ecase type
			  (:unsigned-rational nil)
			  (:signed-rational t)))
		((numerator numerator-bytes) (read-integer 4 stream :byte-order *byte-order*
							   :signed signed))
		((denominator denominator-bytes) (read-integer 4 stream :byte-order *byte-order*
							      :signed signed)))
    (values (/ numerator denominator)
	    (+ numerator-bytes denominator-bytes))))

(defun write-rational (value type stream)
  (let* ((signed (ecase type
		   (:unsigned-rational nil)
		   (:signed-rational t))))
    (+
     (write-integer (numerator value) 4 stream :byte-order *byte-order*
		    :signed signed)
     (write-integer (denominator value) 4 stream :byte-order *byte-order*
		    :signed signed))))  

(defun ensure-non-null-pointer (pointer-value)
  (assert (/= 0 pointer-value)))

(defun tiff-type->defbinary-type (type)
  (ecase type
    ((:unsigned-long :undefined) '(unsigned-byte 32))
    (:signed-long '(signed-byte 32))
    (:double-float 'double-float)
    (:single-float 'single-float)
    (:ascii '(terminated-string 1))
    ((:signed-rational :unsigned-rational)
     `(custom :reader (lambda (stream)
			(read-rational ,type stream))
	      :writer (lambda (obj stream)
			(write-rational obj ,type stream))))
    (:signed-byte '(signed-byte 8))
    (:unsigned-byte '(unsigned-byte 8))
    (:signed-short '(signed-byte 16))
    (:unsigned-short '(unsigned-byte 16))))

(defbinary directory-entry (:byte-order :dynamic)
  (file-position 0 :type file-position)
  (tag 0 :type (unsigned-byte 16))
  (type 0 :type tiff-type)
  (count 0 :type (unsigned-byte 32)
	 :writer (lambda (obj stream)
		   (declare (ignore obj))
		   (setf count (if (eq type :ascii)
				   (1+ (length value))
				   (if (or (listp value)
					   (vectorp value))
				       (length value)
				       1)))
		   (write-integer count 4 stream :byte-order *byte-order*)))
  The VALUE depends on both the TYPE and the COUNT . The total number of
  bytes needed to store the VALUE is given by ( size of the type ) * ( count ) .
  If this size is > 4 bytes , then the type of the VALUE must resolve to :
    ( pointer : pointer - type ( unsigned - byte 32 )
  The BASE - POINTER is declared at the beginning of the TIFF type definition ,
  TIFF - REGION is also declared in the TIFF type definition , and determines
  (value 0 :type (eval
		  (cond
  This tells LISP - BINARY that strings with a count < = 4
  ( which includes the terminating NUL ) will fit inside
  the VALUE , so we do n't need a pointer .
		    ((and (eq type :ascii)
			  (<= count 4))
		     (tiff-type->defbinary-type :ascii))
  count < = 4 and short arrays with count < = 2
  will fit within the VALUE .
		    ((or (and (member type '(:signed-byte :unsigned-byte))
			      (<= count 4)
			      (> count 1))
			 (and (member type '(:signed-short :unsigned-short))
			      (= count 2)))
		     `(simple-array ,(tiff-type->defbinary-type type)
				    (,count)))
		    ((> count 1)
		     `(pointer :pointer-type (unsigned-byte 32)
			       :data-type ,(if (eq type :ascii)
					       (tiff-type->defbinary-type :ascii)
					       `(simple-array ,(tiff-type->defbinary-type type) (,count)))
			       :base-pointer-name 'tiff-base-pointer
			       :validator #'ensure-non-null-pointer
			       :region-tag 'tiff-region))
  as pointers to Image File Directories .
  EXIF
  Interoperability
		     `(pointer :pointer-type (unsigned-byte 32)
			       :data-type tiff-image-file-directory
			       :base-pointer-name 'tiff-base-pointer
			       :validator #'ensure-non-null-pointer
			       :region-tag 'tiff-region))
		    (t
		     (case type
		       ((:undefined)
			'(unsigned-byte 32))
  Some types are just plain too big to fit in the VALUE .
		       ((:double-float :signed-rational :unsigned-rational :ascii)
			`(pointer :pointer-type (unsigned-byte 32)
				  :data-type ,(tiff-type->defbinary-type type)
				  :base-pointer-name 'tiff-base-pointer
				  :validator #'ensure-non-null-pointer
				  :region-tag 'tiff-region))
		       (otherwise (tiff-type->defbinary-type type)))))))
  If the VALUE does n't use 32 bits , then it must be padded . The PADDING
  is an unsigned integer that fills in the space not used by the VALUE .
  (padding 0 :type (eval (if (> count 1)
			     'null
			     (ecase type
			       (:ascii
				(if (>= count 4)
				    'null
				    `(unsigned-byte ,(* 8 (- 4 count)))))
			       ((:unsigned-long :unsigned-rational :signed-rational :double-float :signed-long
						:single-float :undefined)
				'null)
			       ((:signed-byte :unsigned-byte)
				'(unsigned-byte 24))
			       ((:signed-short :unsigned-short)
				'(unsigned-byte 16)))))))

(defbinary tiff-image-file-directory
    (:align 2 :byte-order :dynamic)
  (directory-entries #() :type (counted-array 2 directory-entry))
  (next-directory-offset 0 :type (unsigned-byte 32)))

(defun write-integer/debug (&rest arguments)
  (format t "Calling ~S~%" (cons 'write-integer arguments))
  (apply #'write-integer arguments))

(defbinary tiff (:byte-order :dynamic :preserve-*byte-order* nil)
  (tiff-base-pointer 0 :type base-pointer)
  (byte-order 0 :type tiff-byte-order :reader (lambda (stream)
						      (values
						       (setf *byte-order* (read-binary-type 'tiff-byte-order stream))
						       2)))
  (magic 42 :type (magic :actual-type (unsigned-byte 16)
			 :value 42))
  (offset-ptr 0 :type file-position)
  (first-image-file-directory-offset 0 :type (unsigned-byte 32))
  (image-directories nil :type (custom
				:reader (lambda (stream)
					  (let* ((next-directory nil)
						 (byte-count 0)
						 (directories
						  (with-file-position (0 stream)
						    (loop for offset = first-image-file-directory-offset
						       then (slot-value next-directory 'next-directory-offset)
						       until (= offset 0)
						       collect (progn
								 (file-position stream (+ offset tiff-base-pointer))
								 (setf next-directory
								       (multiple-value-bind (dir bytes)
									   (read-binary 'tiff-image-file-directory stream)
									 (incf byte-count bytes)
									 dir)))))))
					    (values directories byte-count)))
				:writer (lambda (obj stream)
					  (declare (ignore obj))
					  (force-output stream)
					  (let ((real-offset (file-length stream)))
					    (with-file-position (offset-ptr stream)
					      (write-integer (- real-offset tiff-base-pointer) 4 stream :byte-order *byte-order*)
					      (setf first-image-file-directory-offset (- real-offset tiff-base-pointer))
					      (file-position stream real-offset)
					      (loop for (dir . more-dirs) on image-directories sum
						   (let ((bytes (write-binary dir stream))
							 (new-eof (file-position stream)))
						     (force-output stream)
						     (file-position stream (- new-eof 4))
						     (write-integer (if more-dirs
									(- new-eof tiff-base-pointer)
									0) 4 stream :byte-order *byte-order*)
						     bytes)))))))
  (tiff-region 0 :type (region-tag :base-pointer-name 'tiff-base-pointer)))
				    

(defbinary jpeg-generic-tag (:byte-order :big-endian)
  (offset 0 :type file-position)
  (magic #xff :type (magic :actual-type (unsigned-byte 8)
			   :value #xff))
  (code 0 :type (unsigned-byte 8))
  (length-offset 0 :type file-position)
  (length 0 :type (eval
		   (case code
		     ((#xd8 #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7
			    #xd9 #xdd)
		      'null)
		     (otherwise
		      '(unsigned-byte 16)))))
  (restart-interval nil :type (eval
			       (if (= code #xdd)
				   '(unsigned-byte 32)
				   'null))))

(defvar *exif-header* #x457869660000)

(defbinary jpeg-app1-body (:byte-order :big-endian)
  (exif-header 0 :type (unsigned-byte 48))
  (body nil :type (eval (if (= exif-header *exif-header*)
			    'tiff
			    'null))))

(defun jpeg-tag-no-length-p (tag)
  (or (member (slot-value tag 'code)
	      '(#xd8 #xd0 #xd1 #xd2 #xd3 #xd4 #xd5 #xd6 #xd7
		#xd9 #xdd))
      (not (slot-value tag 'length))))


(defbinary jpeg-generic-segment (:byte-order :big-endian)
  (file-position 0 :type file-position)
  (tag nil :type jpeg-generic-tag)
  (contents nil :type (eval
		       (cond ((= (slot-value tag 'code) 225)
			      'jpeg-app1-body)
			     ((null (slot-value tag 'length))
			      'null)
			     (t `(simple-array (unsigned-byte 8) (,(- (slot-value tag 'length) 2)))))))
  (buffer nil :type (eval
		     (if (or (and (jpeg-app1-body-p contents)
				  (tiff-p (slot-value contents 'body)))
			     (jpeg-tag-no-length-p tag))
			 'null
			 `(simple-array (unsigned-byte 8) (,(- (slot-value tag 'length) 8))))))
  (file-positioner nil :type (custom :reader
				     (lambda (stream)
				       (values
					(and (not (jpeg-tag-no-length-p tag))
					     (file-position stream
							    (+ (slot-value tag 'length-offset)
							       (slot-value tag 'length))))
					0))
				     :writer
				     (lambda (obj stream)
				       (declare (ignore obj))
					 (if (jpeg-tag-no-length-p tag)
					     (let ((end-position (file-position stream)))
					       (with-file-position ((slot-value tag 'length-offset) stream)
						 (write-integer (- end-position (slot-value tag 'length-offset))
								2 stream :byte-order :big-endian)))
					   0)))))
							    

(defun read-rest-of-stream (stream)
  (read-bytes (- (file-length stream)
		 (file-position stream))
	      stream))


(defun remove-exif-data (input-file output-file)
  (with-open-binary-file (in input-file)
    (let ((jpeg-segments (loop for segment = (read-binary 'jpeg-generic-segment in)
			    until (= (slot-value
				      (slot-value segment 'tag) 'code) 225)
			    collect segment))
	  (rest-of-image (read-rest-of-stream in)))
      (with-open-binary-file (out output-file
				  :direction :io
				  :if-exists :supersede
				  :if-does-not-exist :create)
	(loop for segment in jpeg-segments
	   do (write-binary segment out))
	(write-bytes rest-of-image out)))))

(defun read/write-test (pathname object type &key (base-pointer 0) tags)
  (with-local-pointer-resolving-context
    (with-open-binary-file (out pathname
				:direction :io
				:if-exists :supersede
				:if-does-not-exist :create)
      (write-binary-type object
			 type out)
      (loop for tag in tags
	 do (lisp-binary::dump-tag tag base-pointer out)))
    (with-open-binary-file (in pathname
			       :direction :input)
      (read-binary-type type in))))
