exif.lisp

   1 ;;;
   2 ;;; exif.lisp
   3 ;;;
   4 ;;; Created: 2005-12-08 by Zach Beane <xach@xach.com>
   5 ;;;
   6 ;;; Copyright (c) 2005 Zachary Beane, All Rights Reserved
   7 ;;;
   8 ;;; Redistribution and use in source and binary forms, with or without
   9 ;;; modification, are permitted provided that the following conditions
  10 ;;; are met:
  11 ;;;
  12 ;;;   * Redistributions of source code must retain the above copyright
  13 ;;;     notice, this list of conditions and the following disclaimer.
  14 ;;;
  15 ;;;   * Redistributions in binary form must reproduce the above
  16 ;;;     copyright notice, this list of conditions and the following
  17 ;;;     disclaimer in the documentation and/or other materials
  18 ;;;     provided with the distribution.
  19 ;;;
  20 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  21 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  22 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  23 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  24 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  25 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  26 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  27 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  28 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  29 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  30 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  31 ;;;
  32 ;;; $Id: exif.lisp,v 1.7 2009/09/08 17:14:22 xach Exp $
  33
  34 (defpackage :zpb-exif
  35   (:use :cl)
  36   (:export :make-exif
  37            ;; IFDs
  38            :image-ifd
  39            :thumbnail-ifd
  40            :exif-ifd
  41            :gps-ifd
  42            :interoperability-ifd
  43            ;; Pulling values from IFDs and entries
  44            :ifd-entry
  45            :entry-value
  46            :parsed-entry-value
  47            ;; Convenience
  48            :exif-value
  49            :parsed-exif-value
  50            :parse-exif-data
  51            :exif-data
  52            :thumbnail-image
  53            :ifd-alist
  54            :exif-alist
  55            ;; Conditions
  56            :invalid-stream
  57            :invalid-jpeg-stream
  58            :invalid-exif-stream)
  59   (:shadow count type))
  60
  61 (in-package :zpb-exif)
  62
  63 \f
  64 ;;; Conditions
  65
  66 (define-condition invalid-stream (error) ())
  67
  68 (define-condition invalid-jpeg-stream (invalid-stream) ())
  69
  70 (define-condition invalid-exif-stream (invalid-stream) ())
  71
  72 (eval-when (:compile-toplevel :load-toplevel :execute)
  73   (defparameter *optimizations*
  74     '(optimize (speed 3) (safety 0)))
  75
  76   (defparameter *optimizations* '(optimize)))
  77
  78 \f
  79 ;;; Fetching data
  80
  81 (defun get-32/lsb (pos buf)
  82   (declare (cl:type (simple-array (unsigned-byte 8) (*)) buf)
  83            (fixnum pos)
  84            #.*optimizations*)
  85   (logand #xFFFFFFFF
  86           (+ (ash (aref buf pos) 0)
  87              (ash (aref buf (incf pos)) 8)
  88              (ash (aref buf (incf pos)) 16)
  89              (ash (aref buf (incf pos)) 24))))
  90
  91 (defun get-32/msb (pos buf)
  92   (declare (cl:type (simple-array (unsigned-byte 8) (*)) buf)
  93            (fixnum pos)
  94            #.*optimizations*)
  95   (logand #xFFFFFFFF
  96           (+ (ash (aref buf pos) 24)
  97              (ash (aref buf (incf pos)) 16)
  98              (ash (aref buf (incf pos)) 8)
  99              (ash (aref buf (incf pos)) 0))))
 100
 101 (defun get-16/lsb (pos buf)
 102   (declare (cl:type (simple-array (unsigned-byte 8) (*)) buf)
 103            (fixnum pos)
 104            #.*optimizations*)
 105   (logand #xFFFF
 106           (+ (ash (aref buf pos) 0)
 107              (ash (aref buf (incf pos)) 8))))
 108
 109 (defun get-16/msb (pos buf)
 110   (declare (cl:type (simple-array (unsigned-byte 8) (*)) buf)
 111            (fixnum pos)
 112            #.*optimizations*)
 113   (logand #xFFFF
 114           (+ (ash (aref buf pos) 8)
 115              (ash (aref buf (incf pos)) 0))))
 116
 117 (defun get-8/* (pos buf)
 118   (declare (cl:type (simple-array (unsigned-byte 8) (*)) buf)
 119            (fixnum pos)
 120            #.*optimizations*)
 121   (logand #xFF (aref buf pos)))
 122
 123 \f
 124 ;;; The exif object
 125
 126 (defclass exif ()
 127   ((file
 128     :initarg :file
 129     :initform nil
 130     :reader file)
 131    (data
 132     :initarg :data
 133     :reader data)
 134    (offset
 135     :initarg :offset
 136     :reader offset
 137     :documentation
 138     "The position in the input stream from where the Exif data was read.")
 139    (get-32-function
 140     :initarg :get-32-function
 141     :reader get-32-function)
 142    (get-16-function
 143     :initarg :get-16-function
 144     :reader get-16-function)
 145    (endianness
 146     :initarg :endianness
 147     :reader endianness)
 148    (image-ifd
 149     :initarg :image-ifd
 150     :initform nil
 151     :accessor image-ifd)
 152    (thumbnail-ifd
 153     :initarg :thumbnail-ifd
 154     :initform nil
 155     :accessor thumbnail-ifd)
 156    (exif-ifd
 157     :initarg :exif-ifd
 158     :initform nil
 159     :accessor exif-ifd)
 160    (gps-ifd
 161     :initarg :gps-ifd
 162     :initform nil
 163     :accessor gps-ifd)
 164    (interoperability-ifd
 165     :initarg :interoperability-ifd
 166     :initform nil
 167     :accessor interoperability-ifd)))
 168
 169 (defun exif-data (exif)
 170   (data exif))
 171
 172 (defun get-8 (pos exif)
 173   (get-8/* pos (data exif)))
 174
 175 (defun get-16 (pos exif)
 176   (funcall (get-16-function exif) pos (data exif)))
 177
 178 (defun get-32 (pos exif)
 179   (funcall (get-32-function exif) pos (data exif)))
 180
 181 (defun get-string (pos length exif)
 182   (let ((data (data exif))
 183         (string (make-string (1- length))))
 184     (loop for i from pos
 185           for j from 0
 186           repeat (1- length)
 187           do (setf (char string j) (code-char (aref data i))))
 188     string))
 189
 190 \f
 191 ;;; Reading the various data types
 192
 193 (defun long->slong (long)
 194   (if (logbitp 31 long)
 195       (dpb long (byte 32 0) -1)
 196       long))
 197
 198 (defmacro do-gets ((j start step count) &body body)
 199   "Evaluate BODY COUNT times, binding J to START initially, then
 200 incrementing it by STEP. The results of the evaluation are returned as
 201 a vector."
 202   (let ((result (gensym))
 203         (i (gensym)))
 204     `(do ((,result (make-array ,count))
 205           (,i 0 (1+ ,i ))
 206           (,j ,start (+ ,j ,step)))
 207          ((= ,i ,count) ,result)
 208       (setf (aref ,result ,i)
 209        ,@body))))
 210
 211 (defun get-byte (type count pos exif)
 212   (declare (ignore type))
 213   (if (= count 1)
 214       (get-8 pos exif)
 215       (subseq (data exif) pos (+ pos count))))
 216
 217 (defun get-ascii (type count pos exif)
 218   (declare (ignore type))
 219   (get-string pos count exif))
 220
 221 (defun get-short (type count pos exif)
 222   (declare (ignore type))
 223   (if (= count 1)
 224       (get-16 pos exif)
 225       (do-gets (i pos 2 count)
 226         (get-16 i exif))))
 227
 228 (defun get-long (type count pos exif)
 229   (declare (ignore type))
 230   (if (= count 1)
 231       (get-32 pos exif)
 232       (do-gets (i pos 4 count)
 233         (get-32 i exif))))
 234
 235 (defun get-rational (type count pos exif)
 236   (declare (ignore type))
 237   (if (= count 1)
 238       (let ((numerator (get-32 pos exif))
 239             (denominator (get-32 (+ 4 pos ) exif)))
 240         (if (zerop denominator)
 241             0
 242             (/ numerator denominator)))
 243       (do-gets (i pos 8 count)
 244         (let ((numerator (get-32 i exif))
 245               (denominator (get-32 (+ 4 i) exif)))
 246           (if (zerop denominator)
 247               0
 248               (/ numerator denominator))))))
 249
 250 (defun get-undefined (type count pos exif)
 251   (declare (ignore type))
 252   (subseq (data exif) pos (+ pos count)))
 253
 254 (defun get-slong (type count pos exif)
 255   (declare (ignore type))
 256   (if (= count 1)
 257       (long->slong (get-32 pos exif))
 258       (do-gets (i pos 4 count)
 259         (long->slong (get-32 i exif)))))
 260
 261 (defun get-srational (type count pos exif)
 262   (declare (ignore type))
 263   (if (= count 1)
 264       (/ (long->slong (get-32 pos exif))
 265          (long->slong (get-32 (+ pos 4) exif)))
 266       (do-gets (i pos 8 count)
 267         (/ (long->slong (get-32 i exif))
 268            (long->slong (get-32 (+ i 4) exif))))))
 269
 270 (defun get-unknown-type (type &rest args)
 271   (declare (ignore args))
 272   (warn "Encountered unknown data type ~D, ignoring" type)
 273   nil)
 274
 275 (defparameter *type-readers*
 276   #(get-unknown-type          ; 0
 277     get-byte                  ; 1
 278     get-ascii                 ; 2
 279     get-short                 ; 3
 280     get-long                  ; 4
 281     get-rational              ; 5
 282     get-unknown-type          ; 6
 283     get-undefined             ; 7
 284     get-unknown-type          ; 8
 285     get-slong                 ; 9
 286     get-srational             ;10
 287     get-unknown-type          ;11
 288     get-unknown-type          ;12
 289     get-unknown-type          ;13
 290     get-unknown-type          ;14
 291     get-unknown-type          ;15
 292     ))
 293
 294 \f
 295 ;;; IFDs
 296
 297 (defclass ifd ()
 298   ((tagset
 299     :initarg :tagset
 300     :accessor tagset)
 301    (entries
 302     :initarg :entries
 303     :accessor entries)
 304    (next-ifd-offset
 305     :initarg :next-ifd-offset
 306     :initform 0
 307     :accessor next-ifd-offset)))
 308
 309 (defmethod print-object ((ifd ifd) stream)
 310   (print-unreadable-object (ifd stream :type t :identity t)
 311     (format stream "(~D entries)" (length (entries ifd)))))
 312
 313 (defclass ifd-entry ()
 314   ((exif
 315     :initarg :exif
 316     :reader exif)
 317    (ifd
 318     :initarg :ifd
 319     :reader ifd)
 320    (tag
 321     :initarg :tag
 322     :reader tag)
 323    (type
 324     :initarg :type
 325     :reader type)
 326    (count
 327     :initarg :count
 328     :reader count)
 329    (value-offset
 330     :initarg :value-offset
 331     :reader value-offset)
 332    (value
 333     :initarg :value
 334     :reader %value
 335     :writer (setf value))))
 336
 337 (defun immediate-value-p (type count)
 338   "Can COUNT items of TYPE be stored in the 32-bit IFD entry value
 339 offset area?"
 340   (case type
 341     ;; octet-sized types
 342     ((1 2 7) (<= count 4))
 343     ;; 16-bit type
 344     (3 (< count 2))
 345     ;; 32-bit types
 346     ((4 9) (= count 1))))
 347
 348 (defun read-ifd-value (type count pos exif)
 349   (funcall (aref *type-readers* type) type count pos exif))
 350
 351 (defun read-ifd-entry (pos ifd exif)
 352   (let ((tag (get-16 pos exif))
 353         (type (get-16 (+ pos 2) exif))
 354         (count (get-32 (+ pos 4) exif))
 355         (value-offset (get-32 (+ pos 8) exif)))
 356     (let ((ifd-entry (make-instance 'ifd-entry
 357                                     :exif exif
 358                                     :ifd ifd
 359                                     :tag tag
 360                                     :type type
 361                                     :count count
 362                                     :value-offset value-offset)))
 363       (when (immediate-value-p type count)
 364         (setf (value ifd-entry) (read-ifd-value type count (+ pos 8) exif)))
 365       ifd-entry)))
 366
 367 (defun read-ifd (pos tagset exif)
 368   (let* ((entry-count (get-16 pos exif))
 369          (entries (make-array entry-count))
 370          (next-ifd-offset (get-32 (+ pos 2 (* 12 entry-count)) exif))
 371          (ifd (make-instance 'ifd
 372                              :tagset tagset
 373                              :entries entries
 374                              :next-ifd-offset next-ifd-offset)))
 375     (loop for i below entry-count
 376           for j from 2 by 12
 377           do (setf (aref entries i) (read-ifd-entry (+ pos j) ifd exif)))
 378     ifd))
 379
 380 (defun initialize-ifd-entry (ifd-entry)
 381   (with-slots (exif type count value-offset)
 382       ifd-entry
 383     (setf (value ifd-entry) (read-ifd-value type count value-offset exif))))
 384
 385 (defun entry-value (ifd-entry)
 386   (when ifd-entry
 387     (if (slot-boundp ifd-entry 'value)
 388         (%value ifd-entry)
 389         (initialize-ifd-entry ifd-entry))))
 390
 391 (defun bisect-find (object vector &key (key #'identity))
 392   (let ((lo 0)
 393         (hi (length vector))
 394         (mid nil))
 395     (loop
 396      (when (<= hi lo)
 397        (return))
 398      (setf mid (ash (+ hi lo) -1))
 399      (let ((candidate (funcall key (aref vector mid))))
 400        (cond ((= candidate object)
 401               (return (aref vector mid)))
 402              ((< object candidate)
 403               (setf hi mid))
 404              (t
 405               (setf lo (1+ mid))))))))
 406
 407 (defun %ifd-entry (tag ifd)
 408   (when ifd
 409     (bisect-find tag (entries ifd) :key #'tag)))
 410
 411
 412 ;;;
 413 ;;; Initializing IFDs in the exif
 414 ;;;
 415 ;;; An IFD is a directory of tag/value structures. Exif defines
 416 ;;; separate IFD tags for image information, exif-specific
 417 ;;; information, GPS information, and interoperability
 418 ;;; information. There may be image, exif, and GPS IFDs for both the
 419 ;;; primary image and the thumbnail image.
 420 ;;;
 421 ;;; The image information IFD has pointers to exif and GPS IFDs. The
 422 ;;; exif IFD has a pointer to the interoperability IFD.
 423 ;;;
 424 ;;; FIXME: GPS and Exif IFDs for the thumbnail image are ignored.
 425 ;;;
 426
 427 (defun initialize-exif-ifds (exif)
 428   (let ((image-ifd-offset (get-32 4 exif)))
 429     (with-slots (image-ifd thumbnail-ifd exif-ifd
 430                  gps-ifd interoperability-ifd)
 431         exif
 432       (setf image-ifd (read-ifd image-ifd-offset 'image exif))
 433       (unless (zerop (next-ifd-offset image-ifd))
 434         (setf thumbnail-ifd (read-ifd (next-ifd-offset image-ifd)
 435                                       'image
 436                                       exif)))
 437       (let ((exif-ifd-offset (entry-value (%ifd-entry #x8769 image-ifd)))
 438             (gps-ifd-offset (entry-value (%ifd-entry #x8825 image-ifd))))
 439         (when exif-ifd-offset
 440           (setf exif-ifd (read-ifd exif-ifd-offset 'exif exif))
 441           (let ((interoperability-ifd-offset (entry-value (%ifd-entry
 442                                                            #xA005
 443                                                            exif-ifd))))
 444             (when interoperability-ifd-offset
 445               (setf interoperability-ifd (read-ifd interoperability-ifd-offset
 446                                                    'interoperability
 447                                                    exif)))))
 448         (when gps-ifd-offset
 449           (setf gps-ifd (read-ifd gps-ifd-offset 'gps exif)))
 450         exif))))
 451
 452
 453
 454 \f
 455 ;;; Creating an exif object from a stream
 456
 457 (defparameter *reader-functions/msb*
 458   '(get-32/msb
 459     get-16/msb))
 460
 461 (defparameter *reader-functions/lsb*
 462   '(get-32/lsb
 463     get-16/lsb))
 464
 465 (defun read-jpeg-uint16 (stream)
 466   (logand #xFFFF
 467           (+ (ash (read-byte stream) 8)
 468              (read-byte stream))))
 469
 470 (defun check-bytes (stream &rest bytes)
 471   "Return true if next bytes of STREAM match the list BYTES."
 472   (loop for byte in bytes
 473         always (= (read-byte stream) byte)))
 474
 475 (defun seek-to-app1 (stream)
 476   "Position STREAM after the #xFF, #xE1 marker in the JPEG stream
 477 representing the APP1 segment. Raise an INVALID-EXIF-STREAM error if
 478 no APP1 segment can be found."
 479   (do ((first-byte (read-byte stream nil) next-byte)
 480        (next-byte (read-byte stream nil) (read-byte stream nil)))
 481       ((not (and first-byte next-byte)))
 482     (cond ((and (= first-byte #xFF) (= next-byte #xE1))
 483            (return))
 484           ((and (= first-byte #xFF) (<= #xE0 next-byte #xEF))
 485            (let ((appn-size (read-jpeg-uint16 stream)))
 486              (file-position stream (+ (file-position stream)
 487                                       (- appn-size 2)))))
 488           ((= next-byte #xFF)
 489            ;; padding -- do nothing
 490            )
 491           (t
 492            (error 'invalid-exif-stream)))))
 493
 494 (defun make-exif-from-stream (stream)
 495   "Extract an Exif object from the open (unsigned-byte 8) STREAM. The
 496 stream must be positioned at the beginning of JPEG data. If the stream
 497 is not a JPEG stream, raise INVALID-JPEG-STREAM. If the stream does
 498 not contain Exif data, raise INVALID-EXIF-STREAM."
 499   (unless (check-bytes stream #xFF #xD8)
 500     (error 'invalid-jpeg-stream))
 501   (seek-to-app1 stream)
 502   (let ((size (read-jpeg-uint16 stream)))
 503     ;; ASCII "Exif"
 504     (unless (check-bytes stream #x45 #x78 #x69 #x66 #x00 #x00)
 505       (error 'invalid-exif-stream))
 506     (let ((data (make-array size :element-type '(unsigned-byte 8)))
 507           (offset (file-position stream)))
 508       (read-sequence data stream)
 509       ;; ASCII #\I or #\M
 510       (let ((endianness (if (= (aref data 0) (aref data 1) #x49)
 511                             :lsb
 512                             :msb)))
 513         (destructuring-bind (get-32 get-16)
 514             (if (eql endianness :lsb)
 515                 *reader-functions/lsb*
 516                 *reader-functions/msb*)
 517           (initialize-exif-ifds
 518            (make-instance 'exif
 519                           :file (ignore-errors (truename stream))
 520                           :data data
 521                           :offset offset
 522                           :endianness endianness
 523                           :get-32-function get-32
 524                           :get-16-function get-16)))))))
 525
 526 (defun make-exif-from-file (file)
 527   (with-open-file (stream file
 528                           :direction :input
 529                           :element-type '(unsigned-byte 8))
 530     (make-exif-from-stream stream)))
 531
 532 (defun make-exif (object)
 533   "Read and create an exif object from OBJECT, which may be a pathname
 534 designator or a stream."
 535   (etypecase object
 536     ((or string pathname) (make-exif-from-file object))
 537     (stream (make-exif-from-stream object))))
 538
 539 \f
 540 ;;; Tagsets
 541 ;;;
 542 ;;; This is necessary because, unfortunately, tags are only unique
 543 ;;; within a particular IFD. The GPS and interoperability IFDs, for
 544 ;;; example, have conflicting tags.
 545
 546 (defclass tagset-entry ()
 547   ((tag
 548     :initarg :tag
 549     :reader tag)
 550    (name
 551     :initarg :name
 552     :reader name)
 553    (type
 554     :initarg :type
 555     :reader type)))
 556
 557 (defun tag-name (code tagset)
 558   (let ((table (get tagset 'tagset-code-table)))
 559     (if table
 560         (let ((entry (gethash code table)))
 561           (when entry
 562             (name entry)))
 563         (error "~A is not a known tagset" tagset))))
 564
 565 (defun tag-type (code tagset)
 566   (let ((table (get tagset 'tagset-code-table)))
 567     (if table
 568         (let ((entry (gethash code table)))
 569           (when entry
 570             (type entry)))
 571         (error "~A is not a known tagset" tagset))))
 572
 573 (defun tag-code (name tagset)
 574   (let ((table (get tagset 'tagset-name-table)))
 575     (if table
 576         (nth-value 0 (gethash name table))
 577         (error "~A is not a known tagset" tagset))))
 578
 579 (defmacro define-tagset (name &body tag-definitions)
 580   (let ((name-table (gensym))
 581         (code-table (gensym))
 582         (setfs '()))
 583     `(let ((,name-table (make-hash-table :test 'equalp))
 584            (,code-table (make-hash-table)))
 585       (setf (get ',name 'tagset-name-table) ,name-table
 586        (get ',name 'tagset-code-table) ,code-table)
 587       ,@(dolist (definition tag-definitions setfs)
 588           (destructuring-bind (&key tag name type)
 589               definition
 590             (push `(setf (gethash ,name ,name-table) ,tag
 591                     (gethash ,tag ,code-table) (make-instance 'tagset-entry
 592                                                 :tag ,tag
 593                                                 :name ,name
 594                                                 :type ',type))
 595                     setfs))))))
 596
 597
 598 ;;; Converting some Exif values to somewhat more parsed values
 599
 600 (defun exif-type-parser-fun (exif-type)
 601   (or (get exif-type 'exif-type-parser-fun) 'identity))
 602
 603 (defmacro define-exif-type (name (base-type) &rest options)
 604   (declare (ignore base-type))
 605   (let ((forms
 606          (loop for ((type . parameters)) on options
 607                when (eql type :parser)
 608                collect (destructuring-bind (lambda-list &body body)
 609                            parameters
 610                          `(setf (get ',name 'exif-type-parser-fun)
 611                            (lambda ,lambda-list ,@body))))))
 612     (when forms
 613       `(progn ,@forms))))
 614
 615 (defun parse-datetime (string)
 616   "Convert an Exif datetime string in the form \"YYYY:MM:DD hh:mm:ss\"
 617 to a universal time."
 618   ;; YYYY:MM:DD hh:mm:ss
 619   ;; 0123456789012345678
 620   (flet ((integer-at (start end)
 621            (parse-integer string :start start :end end)))
 622     (encode-universal-time (integer-at 17 19)
 623                            (integer-at 14 16)
 624                            (integer-at 11 13)
 625                            (integer-at  8 10)
 626                            (integer-at  5  7)
 627                            (integer-at  0  4))))
 628
 629 ;;;
 630 ;;; It was no fun to type all these in from JEITA CP-3451
 631 ;;;
 632
 633 ;;; Generic types, used multiple times
 634
 635 (define-exif-type datetime (ascii)
 636   (:parser (value)
 637     (parse-datetime value)))
 638
 639 (define-exif-type floatable-rational (rational)
 640   (:parser (value)
 641     (float value)))
 642
 643 ;;; One-off types; used for a specific tag in a tagset
 644
 645 (define-exif-type orientation (short)
 646   (:parser (value)
 647     (case value
 648       (1 :normal)
 649       (2 :flipped-horizontally)
 650       (3 :rotated-180)
 651       (4 :flipped-vertically)
 652       (5 :rotated-270-and-flipped-horizontally)
 653       (6 :rotated-270)
 654       (7 :rotated-90-and-flipped-vertically)
 655       (8 :rotated-90)
 656       (otherwise :reserved))))
 657
 658 (define-exif-type exposure-program (short)
 659   (:parser (value)
 660     (case value
 661       (0 :not-defined)
 662       (1 :manual)
 663       (2 :normal-program)
 664       (3 :aperture-priority)
 665       (4 :shutter-priority)
 666       (5 :creative-program)
 667       (6 :action-program)
 668       (7 :portrait-mode)
 669       (8 :landscape-mode)
 670       (otherwise :reserved))))
 671
 672 (define-exif-type sensing-method (short)
 673   (:parser (value)
 674     (case value
 675       (1 :not-defined)
 676       (2 :one-chip-color-area-sensor)
 677       (3 :two-chip-color-area-sensor)
 678       (4 :three-chip-color-area-sensor)
 679       (5 :color-sequential-area-sensor)
 680       (6 :trilinear-sensor)
 681       (7 :color-sequential-linear-sensor)
 682       (otherwise :reserved))))
 683
 684 (define-exif-type metering-mode (short)
 685   (:parser (value)
 686     (case value
 687       (0 :unknown)
 688       (1 :average)
 689       (2 :center-weighted-average)
 690       (3 :spot)
 691       (4 :multispot)
 692       (5 :pattern)
 693       (6 :partial)
 694       (255 :other)
 695       (otherwise :reserved))))
 696
 697 (define-exif-type light-source (short)
 698   (:parser (value)
 699     (case value
 700       (0 :unknown)
 701       (1 :daylight)
 702       (2 :flourescent)
 703       (3 :tungsten)
 704       (4 :flash)
 705       (9 :fine-weather)
 706       (10 :cloudy-weather)
 707       (11 :shade)
 708       (12 :daylight-flourescent)
 709       (13 :day-white-flourescent)
 710       (14 :cool-white-flourescent)
 711       (15 :white-flourescent)
 712       (17 :standard-light-a)
 713       (18 :standard-light-b)
 714       (19 :standard-light-c)
 715       (20 :d55)
 716       (21 :d65)
 717       (22 :d75)
 718       (23 :d50)
 719       (24 :iso-studio-tungsten)
 720       (255 :other-light-source)
 721       (otherwise :reserved))))
 722
 723 (define-exif-type flash (short)
 724   (:parser (value)
 725     ;; FIXME: a gross simplification
 726     (logbitp 0 value)))
 727
 728 (define-exif-type exposure-mode (short)
 729   (:parser (value)
 730     (case value
 731       (0 :auto-exposure)
 732       (1 :manual-exposure)
 733       (2 :auto-bracket)
 734       (otherwise :reserved))))
 735
 736 (define-exif-type white-balance (short)
 737   (:parser (value)
 738     (case value
 739       (0 :auto)
 740       (1 :manual)
 741       (otherwise :reserved))))
 742
 743 (define-exif-type scene-capture-type (short)
 744   (:parser (value)
 745     (case value
 746       (0 :standard)
 747       (1 :landscape)
 748       (2 :portrait)
 749       (3 :night-scene)
 750       (otherwise :reserved))))
 751
 752 (define-exif-type gain-control (short)
 753   (:parser (value)
 754     (case value
 755       (0 :none)
 756       (1 :low-gain-up)
 757       (2 :high-gain-up)
 758       (3 :low-gain-down)
 759       (4 :high-gain-down)
 760       (otherwise :reserved))))
 761
 762 (define-exif-type contrast (short)
 763   (:parser (value)
 764     (case value
 765       (0 :normal)
 766       (1 :soft)
 767       (2 :hard)
 768       (otherwise :reserved))))
 769
 770 (define-exif-type saturation (short)
 771   (:parser (value)
 772     (case value
 773       (0 :normal)
 774       (1 :low-saturation)
 775       (2 :high-saturation)
 776       (otherwise :reserved))))
 777
 778 (define-exif-type sharpness (short)
 779   (:parser (value)
 780     (case value
 781       (0 :normal)
 782       (1 :soft)
 783       (2 :hard)
 784       (otherwise :reserved))))
 785
 786 (define-exif-type subject-distance-range (short)
 787   (:parser (value)
 788     (case value
 789       (0 :unknown)
 790       (1 :macro)
 791       (2 :close-view)
 792       (3 :distant-view)
 793       (otherwise :reserved))))
 794
 795 (define-exif-type exif-version (unknown)
 796   (:parser (value)
 797     ;; FIXME: ASCII-centric
 798     (let ((version-string (make-array 5 :initial-element (char-code #\.))))
 799       (replace version-string value :start2 0 :end2 2)
 800       (replace version-string value :start1 3 :start2 2)
 801       (string-trim '(#\0) (map 'string #'code-char version-string)))))
 802
 803 (define-exif-type color-space (short)
 804   (:parser (value)
 805     (case value
 806       (1 :srgb)
 807       (#xFFFF :uncalibrated)
 808       (otherwise :reserved))))
 809
 810 (define-exif-type user-comment (undefined)
 811   (:parser (value)
 812     (flet ((starts-with (prefix)
 813              (loop for i across prefix
 814                    for j across value
 815                    always (= i j))))
 816       (cond ((or (starts-with #(0 0 0 0 0 0 0 0))
 817                  (starts-with #(#x41 #x53 #x43 #x49 #x49)))
 818              ;; ASCII encoding
 819              (let ((first-null (or (position 0 value :start 8)
 820                                    (length value))))
 821                (map 'string #'code-char (subseq value 8 first-null))))
 822             (t value)))))
 823
 824 (define-exif-type ycbcr-positioning (short)
 825   (:parser (value)
 826     (case value
 827       (1 :centered)
 828       (2 :co-sited)
 829       (otherwise :reserved))))
 830
 831 (define-tagset image
 832   ;; Tags relating to image data structure
 833   (:tag #x0100 :name "ImageWidth" :type short/long)
 834   (:tag #x0101 :name "ImageHeight" :type short/long)
 835   (:tag #x0102 :name "BitsPerSample" :type short)
 836   (:tag #x0103 :name "Compression" :type short)
 837   (:tag #x0106 :name "PhotometricInterpretation" :type short)
 838   (:tag #x0112 :name "Orientation" :type orientation)
 839   (:tag #x0115 :name "SamplesPerPixel" :type short)
 840   (:tag #x011C :name "PlanarConfiguration" :type short)
 841   (:tag #x0212 :name "YCbCrSubSampling" :type short)
 842   (:tag #x0213 :name "YCbCrPositioning" :type ycbcr-positioning)
 843   (:tag #x011A :name "XResolution" :type rational)
 844   (:tag #x011B :name "YResolution" :type rational)
 845   (:tag #x0128 :name "ResolutionUnit" :type short)
 846   ;; Tags relating to recording offset
 847   (:tag #x0111 :name "StripOffsets" :type short/long)
 848   (:tag #x0116 :name "RowsPerStrip" :type short/long)
 849   (:tag #x0117 :name "StripByteCounts" :type short/long)
 850   (:tag #x0201 :name "JPEGInterchangeFormat" :type long)
 851   (:tag #x0202 :name "JPEGInterchangeFormatLength" :type long)
 852   ;; Tags relating to image data characteristics
 853   (:tag #x012D :name "TransferFunction" :type short)
 854   (:tag #x013E :name "WhitePoint" :type rational)
 855   (:tag #x013F :name "PrimaryChromaticities" :type rational)
 856   (:tag #x0211 :name "YCbCrCoefficients" :type rational)
 857   (:tag #x0214 :name "ReferenceBlackWhite" :type rational)
 858   ;; Other tags
 859   (:tag #x0132 :name "DateTime" :type datetime)
 860   (:tag #x010E :name "ImageDescription" :type ascii)
 861   (:tag #x010F :name "Make" :type ascii)
 862   (:tag #x0110 :name "Model" :type ascii)
 863   (:tag #x0131 :name "Software" :type ascii)
 864   (:tag #x013B :name "Artist" :type ascii)
 865   (:tag #x8298 :name "Copyright" :type ascii))
 866
 867 (define-tagset exif
 868   ;; Tags Relating to Version
 869   (:tag #x9000 :name "ExifVersion" :type exif-version)
 870   (:tag #xA000 :name "FlashpixVersion" :type undefined)
 871   ;; Tag Relating to Image Data Characteristics
 872   (:tag #xA001 :name "ColorSpace" :type color-space)
 873   (:tag #xA500 :name "Gamma" :type floatable-rational)
 874   ;; Tags Relating to Image Configuration
 875   (:tag #x9101 :name "ComponentsConfiguration" :type undefined)
 876   (:tag #x9102 :name "CompressedBitsPerPixel" :type rational)
 877   (:tag #xA002 :name "PixelXDimension" :type short/long)
 878   (:tag #xA003 :name "PixelYDimension" :type short/long)
 879   ;; Tags Relating to User Information
 880   (:tag #x927C :name "MakerNote" :type undefined)
 881   (:tag #x9286 :name "UserComment" :type user-comment)
 882   ;; Tag Relating to Related File Information
 883   (:tag #xA004 :name "RelatedSoundFile" :type ascii)
 884   ;; Tags Relating to Date and Time
 885   (:tag #x9003 :name "DateTimeOriginal" :type datetime)
 886   (:tag #x9004 :name "DateTimeDigitized" :type datetime)
 887   (:tag #x9290 :name "SubSecTime" :type ascii)
 888   (:tag #x9291 :name "SubSecTimeOriginal" :type ascii)
 889   (:tag #x9292 :name "SubSecTimeDigitized" :type ascii)
 890   ;; Tags Relating to Picture-Taking Conditions
 891   (:tag #x829A :name "ExposureTime" :type floatable-rational)
 892   (:tag #x829D :name "FNumber" :type floatable-rational)
 893   (:tag #x8822 :name "ExposureProgram" :type exposure-program)
 894   (:tag #x8824 :name "SpectralSensitivity" :type ascii)
 895   (:tag #x8827 :name "ISOSpeedRatings" :type short)
 896   (:tag #x8828 :name "OECF" :type undefined)
 897   (:tag #x9201 :name "ShutterSpeedValue" :type floatable-rational)
 898   (:tag #x9202 :name "ApertureValue" :type floatable-rational)
 899   (:tag #x9203 :name "BrightnessValue" :type srational)
 900   (:tag #x9204 :name "ExposureBiasValue" :type srational)
 901   (:tag #x9205 :name "MaxApertureValue" :type floatable-rational)
 902   (:tag #x9206 :name "SubjectDistance" :type floatable-rational)
 903   (:tag #x9207 :name "MeteringMode" :type metering-mode)
 904   (:tag #x9208 :name "LightSource" :type light-source)
 905   (:tag #x9209 :name "Flash" :type flash)
 906   (:tag #x920A :name "FocalLength" :type floatable-rational)
 907   (:tag #x9214 :name "SubjectArea" :type short)
 908   (:tag #xA20B :name "FlashEngergy" :type rational)
 909   (:tag #xA20C :name "SpatialFrquencyResponse" :type undefined)
 910   (:tag #xA20E :name "FocalPlaneXResolution" :type floatable-rational)
 911   (:tag #xA20F :name "FocalPlaneYResolution" :type floatable-rational)
 912   (:tag #xA210 :name "FocalPlaneResolutionUnit" :type short)
 913   (:tag #xA214 :name "SubjectLocation" :type short)
 914   (:tag #xA215 :name "ExposureIndex" :type rational)
 915   (:tag #xA217 :name "SensingMethod" :type sensing-method)
 916   (:tag #xA300 :name "FileSource" :type undefined)
 917   (:tag #xA301 :name "SceneType" :type undefined)
 918   (:tag #xA302 :name "CFAPattern" :type undefined)
 919   (:tag #xA401 :name "CustomRendered" :type short)
 920   (:tag #xA402 :name "ExposureMode" :type exposure-mode)
 921   (:tag #xA403 :name "WhiteBalance" :type white-balance)
 922   (:tag #xA404 :name "DigitalZoomRatio" :type rational)
 923   (:tag #xA405 :name "FocalLengthIn35mmFilm" :type short)
 924   (:tag #xA406 :name "SceneCaptureType" :type scene-capture-type)
 925   (:tag #xA407 :name "GainControl" :type rational)
 926   (:tag #xA408 :name "Contrast" :type contrast)
 927   (:tag #xA409 :name "Saturation" :type saturation)
 928   (:tag #xA40A :name "Sharpness" :type sharpness)
 929   (:tag #xA40B :name "DeviceSettingDescription" :type undefined)
 930   (:tag #xA40C :name "SubjectDistanceRange" :type subject-distance-range)
 931   ;; Other Tags
 932   (:tag #xA420 :name "ImageUniqueID" :type ascii))
 933
 934 (define-tagset gps
 935   ;; Tags Relating to GPS
 936   (:tag #x0000 :name "GPSVersionID" :type byte)
 937   (:tag #x0001 :name "GPSLatitudeRef" :type ascii)
 938   (:tag #x0002 :name "GPSLatitude" :type rational)
 939   (:tag #x0003 :name "GPSLongitudeRef" :type ascii)
 940   (:tag #x0004 :name "GPSLongitude" :type ascii)
 941   (:tag #x0005 :name "GPSAltitudeRef" :type byte)
 942   (:tag #x0006 :name "GPSAltitude" :type rational)
 943   (:tag #x0007 :name "GPSTimeStamp" :type rational)
 944   (:tag #x0008 :name "GPSSatellites" :type ascii)
 945   (:tag #x0009 :name "GPSStatus" :type ascii)
 946   (:tag #x000A :name "GPSMeasureMode" :type ascii)
 947   (:tag #x000B :name "GPSDOP" :type rational)
 948   (:tag #x000C :name "GPSSpeedRef" :type ascii)
 949   (:tag #x000D :name "GPSSpeed" :type rational)
 950   (:tag #x000E :name "GPSTrackRef" :type ascii)
 951   (:tag #x000F :name "GPSTrack" :type rational)
 952   (:tag #x0010 :name "GPSImgDirectionRef" :type ascii)
 953   (:tag #x0011 :name "GPSImgDirection" :type rational)
 954   (:tag #x0012 :name "GPSMapDatum" :type ascii)
 955   (:tag #x0013 :name "GPSDestLatitudeRef" :type ascii)
 956   (:tag #x0014 :name "GPSDestLatitude" :type rational)
 957   (:tag #x0015 :name "GPSDestLongitudeRef" :type ascii)
 958   (:tag #x0016 :name "GPSDestLongitude" :type rational)
 959   (:tag #x0017 :name "GPSDestBearingRef" :type ascii)
 960   (:tag #x0018 :name "GPSDestBearing" :type rational)
 961   (:tag #x0019 :name "GPSDestDistanceRef" :type ascii)
 962   (:tag #x001A :name "GPSDestDistance" :type rational)
 963   (:tag #x001B :name "GPSProcessingMethod" :type undefined)
 964   (:tag #x001C :name "GPSAreaInformation" :type undefined)
 965   (:tag #x001D :name "GPSDateStamp" :type ascii)
 966   (:tag #x001E :name "GPSDifferential" :type short))
 967
 968 (define-tagset interoperability
 969   (:tag #x0001 :name "InteroperabilityIndex" :type ascii))
 970
 971 (defun tag-designator (tag tagset)
 972   (etypecase tag
 973     (string (tag-code tag tagset))
 974     (symbol (tag-code (symbol-name tag) tagset))
 975     (number tag)))
 976
 977 (defun ifd-entry (tag ifd)
 978   (when ifd
 979     (let ((tag (tag-designator tag (tagset ifd))))
 980       (when tag
 981         (bisect-find tag (entries ifd) :key #'tag)))))
 982
 983 (defun find-ifd-entry (tag exif)
 984   (or (ifd-entry tag (image-ifd exif))
 985       (ifd-entry tag (exif-ifd exif))
 986       (ifd-entry tag (gps-ifd exif))))
 987
 988 (defun exif-value (tag exif)
 989   (entry-value (find-ifd-entry tag exif)))
 990
 991 (defun parsed-entry-value (ifd-entry)
 992   (when ifd-entry
 993     (let* ((type (tag-type (tag ifd-entry) (tagset (ifd ifd-entry))))
 994            (fun (exif-type-parser-fun type)))
 995       (funcall fun (entry-value ifd-entry)))))
 996
 997 (defun parsed-exif-value (tag exif)
 998   (let ((entry (find-ifd-entry tag exif)))
 999     (when entry
1000       (parsed-entry-value entry))))
1001
1002
1003 (defmethod print-object ((ifd-entry ifd-entry) stream)
1004   (print-unreadable-object (ifd-entry stream :type t :identity t)
1005     (let ((name (or (tag-name (tag ifd-entry) (tagset (ifd ifd-entry)))
1006                     "(Unknown Tag)")))
1007       (format stream "~S #x~X/~D/~D"
1008               name
1009               (tag ifd-entry)
1010               (type ifd-entry)
1011               (count ifd-entry)))))
1012
1013 \f
1014 ;;; Miscellaneous utility functions
1015
1016 (defun thumbnail-image (exif)
1017   "Return an (UNSIGNED-BYTE 8) vector containing the JPEG data for the
1018 thumbnail image in EXIF, if present. If there is no thumbnail, return
1019 NIL."
1020   (let ((ifd (thumbnail-ifd exif)))
1021     (flet ((val (tag)
1022              (entry-value (ifd-entry tag ifd))))
1023       (when ifd
1024         (let ((offset (val "JPEGInterchangeFormat"))
1025               (length (val "JPEGInterchangeFormatLength")))
1026           (when (and offset length)
1027             (let ((data (make-array length
1028                                     :element-type '(unsigned-byte 8))))
1029               (replace data (exif-data exif)
1030                        :start2 offset)
1031               data)))))))
1032
1033 ;;; Similar to exifinfo.cl's parse-exif-data
1034
1035 (defun parse-exif-data (file)
1036   (let ((exif (make-exif file)))
1037     (labels ((val (tag)
1038                (exif-value tag exif))
1039              (float-val (tag)
1040                (let ((value (val tag)))
1041                  (and value (float value)))))
1042       (let* ((flash-value (val "Flash"))
1043              (flash-fired-p (and flash-value (not (logand flash-value 1)))))
1044         (list :file (file exif)
1045               :make (val "Make")
1046               :model (val "Model")
1047               :date (val "DateTime")
1048               :comment nil              ; This isn't actually useful
1049               :orientation (val "Orientation")
1050               :exposure (float-val "ExposureTime")
1051               :f-number (float-val "FNumber")
1052               :iso-rating (val "IsoSpeedRatings")
1053               :exposure-bias-value (float-val "ExposureBiasValue")
1054               :subject-distance (float-val "SubjectDistance")
1055               :flash flash-fired-p
1056               :focal-length (float-val "FocalLength")
1057               :image-width (val "PixelXDimension")
1058               :image-length (val "PixelYDimension"))))))
1059
1060
1061 (defun ifd-alist (ifd &key parsedp)
1062   "Return all the values in IFD as an alist."
1063   (when ifd
1064     (loop for entry across (entries ifd)
1065           for name = (or (tag-name (tag entry) (tagset ifd))
1066                          (format nil "Unknown Tag #x~4,'0X" (tag entry)))
1067           collect (cons name
1068                         (if parsedp
1069                             (parsed-entry-value entry)
1070                             (entry-value entry))))))
1071
1072 (defun exif-alist (exif &key parsedp)
1073   "Return the keys and values from the Image, Exif, and GPS IFDs of EXIF."
1074   (with-slots (image-ifd exif-ifd gps-ifd)
1075       exif
1076     (nconc (ifd-alist image-ifd :parsedp parsedp)
1077            (ifd-alist exif-ifd :parsedp parsedp)
1078            (ifd-alist gps-ifd :parsedp parsedp))))
1079