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