4 ;;; Created: 2005-12-08 by Zach Beane <xach@xach.com>
6 ;;; Copyright (c) 2005 Zachary Beane, All Rights Reserved
8 ;;; Redistribution and use in source and binary forms, with or without
9 ;;; modification, are permitted provided that the following conditions
12 ;;; * Redistributions of source code must retain the above copyright
13 ;;; notice, this list of conditions and the following disclaimer.
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.
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.
32 ;;; $Id: exif.lisp,v 1.7 2009/09/08 17:14:22 xach Exp $
43 ;; Pulling values from IFDs and entries
61 (in-package :zpb-exif
)
66 (define-condition invalid-stream
(error) ())
68 (define-condition invalid-jpeg-stream
(invalid-stream) ())
70 (define-condition invalid-exif-stream
(invalid-stream) ())
72 (eval-when (:compile-toplevel
:load-toplevel
:execute
)
73 (defparameter *optimizations
*
74 '(optimize (speed 3) (safety 0)))
76 (defparameter *optimizations
* '(optimize)))
81 (defun get-32/lsb
(pos buf
)
82 (declare (cl:type
(simple-array (unsigned-byte 8) (*)) buf
)
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))))
91 (defun get-32/msb
(pos buf
)
92 (declare (cl:type
(simple-array (unsigned-byte 8) (*)) buf
)
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))))
101 (defun get-16/lsb
(pos buf
)
102 (declare (cl:type
(simple-array (unsigned-byte 8) (*)) buf
)
106 (+ (ash (aref buf pos
) 0)
107 (ash (aref buf
(incf pos
)) 8))))
109 (defun get-16/msb
(pos buf
)
110 (declare (cl:type
(simple-array (unsigned-byte 8) (*)) buf
)
114 (+ (ash (aref buf pos
) 8)
115 (ash (aref buf
(incf pos
)) 0))))
117 (defun get-8/* (pos buf
)
118 (declare (cl:type
(simple-array (unsigned-byte 8) (*)) buf
)
121 (logand #xFF
(aref buf pos
)))
138 "The position in the input stream from where the Exif data was read.")
140 :initarg
:get-32-function
141 :reader get-32-function
)
143 :initarg
:get-16-function
144 :reader get-16-function
)
153 :initarg
:thumbnail-ifd
155 :accessor thumbnail-ifd
)
164 (interoperability-ifd
165 :initarg
:interoperability-ifd
167 :accessor interoperability-ifd
)))
169 (defun exif-data (exif)
172 (defun get-8 (pos exif
)
173 (get-8/* pos
(data exif
)))
175 (defun get-16 (pos exif
)
176 (funcall (get-16-function exif
) pos
(data exif
)))
178 (defun get-32 (pos exif
)
179 (funcall (get-32-function exif
) pos
(data exif
)))
181 (defun get-string (pos length exif
)
182 (let ((data (data exif
))
183 (string (make-string (1- length
))))
187 do
(setf (char string j
) (code-char (aref data i
))))
191 ;;; Reading the various data types
193 (defun long->slong
(long)
194 (if (logbitp 31 long
)
195 (dpb long
(byte 32 0) -
1)
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
202 (let ((result (gensym))
204 `(do ((,result
(make-array ,count
))
206 (,j
,start
(+ ,j
,step
)))
207 ((= ,i
,count
) ,result
)
208 (setf (aref ,result
,i
)
211 (defun get-byte (type count pos exif
)
212 (declare (ignore type
))
215 (subseq (data exif
) pos
(+ pos count
))))
217 (defun get-ascii (type count pos exif
)
218 (declare (ignore type
))
219 (get-string pos count exif
))
221 (defun get-short (type count pos exif
)
222 (declare (ignore type
))
225 (do-gets (i pos
2 count
)
228 (defun get-long (type count pos exif
)
229 (declare (ignore type
))
232 (do-gets (i pos
4 count
)
235 (defun get-rational (type count pos exif
)
236 (declare (ignore type
))
238 (let ((numerator (get-32 pos exif
))
239 (denominator (get-32 (+ 4 pos
) exif
)))
240 (if (zerop denominator
)
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
)
248 (/ numerator denominator
))))))
250 (defun get-undefined (type count pos exif
)
251 (declare (ignore type
))
252 (subseq (data exif
) pos
(+ pos count
)))
254 (defun get-slong (type count pos exif
)
255 (declare (ignore type
))
257 (long->slong
(get-32 pos exif
))
258 (do-gets (i pos
4 count
)
259 (long->slong
(get-32 i exif
)))))
261 (defun get-srational (type count pos exif
)
262 (declare (ignore type
))
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
))))))
270 (defun get-unknown-type (type &rest args
)
271 (declare (ignore args
))
272 (warn "Encountered unknown data type ~D, ignoring" type
)
275 (defparameter *type-readers
*
276 #(get-unknown-type ; 0
305 :initarg
:next-ifd-offset
307 :accessor next-ifd-offset
)))
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
)))))
313 (defclass ifd-entry
()
330 :initarg
:value-offset
331 :reader value-offset
)
335 :writer
(setf value
))))
337 (defun immediate-value-p (type count
)
338 "Can COUNT items of TYPE be stored in the 32-bit IFD entry value
342 ((1 2 7) (<= count
4))
346 ((4 9) (= count
1))))
348 (defun read-ifd-value (type count pos exif
)
349 (funcall (aref *type-readers
* type
) type count pos exif
))
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
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
)))
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
374 :next-ifd-offset next-ifd-offset
)))
375 (loop for i below entry-count
377 do
(setf (aref entries i
) (read-ifd-entry (+ pos j
) ifd exif
)))
380 (defun initialize-ifd-entry (ifd-entry)
381 (with-slots (exif type count value-offset
)
383 (setf (value ifd-entry
) (read-ifd-value type count value-offset exif
))))
385 (defun entry-value (ifd-entry)
387 (if (slot-boundp ifd-entry
'value
)
389 (initialize-ifd-entry ifd-entry
))))
391 (defun bisect-find (object vector
&key
(key #'identity
))
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
)
405 (setf lo
(1+ mid
))))))))
407 (defun %ifd-entry
(tag ifd
)
409 (bisect-find tag
(entries ifd
) :key
#'tag
)))
413 ;;; Initializing IFDs in the exif
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.
421 ;;; The image information IFD has pointers to exif and GPS IFDs. The
422 ;;; exif IFD has a pointer to the interoperability IFD.
424 ;;; FIXME: GPS and Exif IFDs for the thumbnail image are ignored.
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
)
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
)
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
444 (when interoperability-ifd-offset
445 (setf interoperability-ifd
(read-ifd interoperability-ifd-offset
449 (setf gps-ifd
(read-ifd gps-ifd-offset
'gps exif
)))
455 ;;; Creating an exif object from a stream
457 (defparameter *reader-functions
/msb
*
461 (defparameter *reader-functions
/lsb
*
465 (defun read-jpeg-uint16 (stream)
467 (+ (ash (read-byte stream
) 8)
468 (read-byte stream
))))
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
)))
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
))
484 ((and (= first-byte
#xFF
) (<= #xE0 next-byte
#xEF
))
485 (let ((appn-size (read-jpeg-uint16 stream
)))
486 (file-position stream
(+ (file-position stream
)
489 ;; padding -- do nothing
492 (error 'invalid-exif-stream
)))))
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
)))
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
)
510 (let ((endianness (if (= (aref data
0) (aref data
1) #x49
)
513 (destructuring-bind (get-32 get-16
)
514 (if (eql endianness
:lsb
)
515 *reader-functions
/lsb
*
516 *reader-functions
/msb
*)
517 (initialize-exif-ifds
519 :file
(ignore-errors (truename stream
))
522 :endianness endianness
523 :get-32-function get-32
524 :get-16-function get-16
)))))))
526 (defun make-exif-from-file (file)
527 (with-open-file (stream file
529 :element-type
'(unsigned-byte 8))
530 (make-exif-from-stream stream
)))
532 (defun make-exif (object)
533 "Read and create an exif object from OBJECT, which may be a pathname
534 designator or a stream."
536 ((or string pathname
) (make-exif-from-file object
))
537 (stream (make-exif-from-stream object
))))
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.
546 (defclass tagset-entry
()
557 (defun tag-name (code tagset
)
558 (let ((table (get tagset
'tagset-code-table
)))
560 (let ((entry (gethash code table
)))
563 (error "~A is not a known tagset" tagset
))))
565 (defun tag-type (code tagset
)
566 (let ((table (get tagset
'tagset-code-table
)))
568 (let ((entry (gethash code table
)))
571 (error "~A is not a known tagset" tagset
))))
573 (defun tag-code (name tagset
)
574 (let ((table (get tagset
'tagset-name-table
)))
576 (nth-value 0 (gethash name table
))
577 (error "~A is not a known tagset" tagset
))))
579 (defmacro define-tagset
(name &body tag-definitions
)
580 (let ((name-table (gensym))
581 (code-table (gensym))
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
)
590 (push `(setf (gethash ,name
,name-table
) ,tag
591 (gethash ,tag
,code-table
) (make-instance 'tagset-entry
598 ;;; Converting some Exif values to somewhat more parsed values
600 (defun exif-type-parser-fun (exif-type)
601 (or (get exif-type
'exif-type-parser-fun
) 'identity
))
603 (defmacro define-exif-type
(name (base-type) &rest options
)
604 (declare (ignore base-type
))
606 (loop for
((type . parameters
)) on options
607 when
(eql type
:parser
)
608 collect
(destructuring-bind (lambda-list &body body
)
610 `(setf (get ',name
'exif-type-parser-fun
)
611 (lambda ,lambda-list
,@body
))))))
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)
630 ;;; It was no fun to type all these in from JEITA CP-3451
633 ;;; Generic types, used multiple times
635 (define-exif-type datetime
(ascii)
637 (parse-datetime value
)))
639 (define-exif-type floatable-rational
(rational)
643 ;;; One-off types; used for a specific tag in a tagset
645 (define-exif-type orientation
(short)
649 (2 :flipped-horizontally
)
651 (4 :flipped-vertically
)
652 (5 :rotated-270-and-flipped-horizontally
)
654 (7 :rotated-90-and-flipped-vertically
)
656 (otherwise :reserved
))))
658 (define-exif-type exposure-program
(short)
664 (3 :aperture-priority
)
665 (4 :shutter-priority
)
666 (5 :creative-program
)
670 (otherwise :reserved
))))
672 (define-exif-type sensing-method
(short)
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
))))
684 (define-exif-type metering-mode
(short)
689 (2 :center-weighted-average
)
695 (otherwise :reserved
))))
697 (define-exif-type light-source
(short)
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
)
719 (24 :iso-studio-tungsten
)
720 (255 :other-light-source
)
721 (otherwise :reserved
))))
723 (define-exif-type flash
(short)
725 ;; FIXME: a gross simplification
728 (define-exif-type exposure-mode
(short)
734 (otherwise :reserved
))))
736 (define-exif-type white-balance
(short)
741 (otherwise :reserved
))))
743 (define-exif-type scene-capture-type
(short)
750 (otherwise :reserved
))))
752 (define-exif-type gain-control
(short)
760 (otherwise :reserved
))))
762 (define-exif-type contrast
(short)
768 (otherwise :reserved
))))
770 (define-exif-type saturation
(short)
776 (otherwise :reserved
))))
778 (define-exif-type sharpness
(short)
784 (otherwise :reserved
))))
786 (define-exif-type subject-distance-range
(short)
793 (otherwise :reserved
))))
795 (define-exif-type exif-version
(unknown)
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
)))))
803 (define-exif-type color-space
(short)
807 (#xFFFF
:uncalibrated
)
808 (otherwise :reserved
))))
810 (define-exif-type user-comment
(undefined)
812 (flet ((starts-with (prefix)
813 (loop for i across prefix
816 (cond ((or (starts-with #(0 0 0 0 0 0 0 0))
817 (starts-with #(#x41
#x53
#x43
#x49
#x49
)))
819 (let ((first-null (or (position 0 value
:start
8)
821 (map 'string
#'code-char
(subseq value
8 first-null
))))
824 (define-exif-type ycbcr-positioning
(short)
829 (otherwise :reserved
))))
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
)
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
))
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
)
932 (:tag
#xA420
:name
"ImageUniqueID" :type ascii
))
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
))
968 (define-tagset interoperability
969 (:tag
#x0001
:name
"InteroperabilityIndex" :type ascii
))
971 (defun tag-designator (tag tagset
)
973 (string (tag-code tag tagset
))
974 (symbol (tag-code (symbol-name tag
) tagset
))
977 (defun ifd-entry (tag ifd
)
979 (let ((tag (tag-designator tag
(tagset ifd
))))
981 (bisect-find tag
(entries ifd
) :key
#'tag
)))))
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
))))
988 (defun exif-value (tag exif
)
989 (entry-value (find-ifd-entry tag exif
)))
991 (defun parsed-entry-value (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
)))))
997 (defun parsed-exif-value (tag exif
)
998 (let ((entry (find-ifd-entry tag exif
)))
1000 (parsed-entry-value entry
))))
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
)))
1007 (format stream
"~S #x~X/~D/~D"
1011 (count ifd-entry
)))))
1014 ;;; Miscellaneous utility functions
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
1020 (let ((ifd (thumbnail-ifd exif
)))
1022 (entry-value (ifd-entry tag 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
)
1033 ;;; Similar to exifinfo.cl's parse-exif-data
1035 (defun parse-exif-data (file)
1036 (let ((exif (make-exif file
)))
1038 (exif-value tag exif
))
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
)
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"))))))
1061 (defun ifd-alist (ifd &key parsedp
)
1062 "Return all the values in IFD as an alist."
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
)))
1069 (parsed-entry-value entry
)
1070 (entry-value entry
))))))
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
)
1076 (nconc (ifd-alist image-ifd
:parsedp parsedp
)
1077 (ifd-alist exif-ifd
:parsedp parsedp
)
1078 (ifd-alist gps-ifd
:parsedp parsedp
))))