#!/bin/sh #| -*- scheme -*- exec mzscheme -ue- "$0" "(exif-command-line argv)" "$@" |# (module exif mzscheme (provide extract-thumbnail? post-process-data? scheme-style? filename-printer get-exif-data get-exif-thumb exif-command-line (rename exif-error current-exif-error)) ;; customization parameters (define extract-thumbnail? (make-parameter #t)) ; get thumbnail JPEG bytes (define post-process-data? (make-parameter #t)) ; convert numbers to labels etc (define scheme-style? (make-parameter #t)) ; scheme-style InsteadOfThis (define filename-printer ; used to display file name headers (make-parameter (lambda (name) (printf "~a:\n" name)))) (define format-table '(( 1 1 integer u) ( 2 1 bytes ) ( 3 2 integer u) ( 4 4 integer u) ( 5 8 rational u) ( 6 1 integer s) ( 7 1 undefined ) ( 8 2 integer s) ( 9 4 integer s) (10 8 rational s) (11 4 float ) (12 8 float ))) (define tag-table '(;; Each of these entries has: ;; * a numeric tag, ;; * the symbolic equivalence, ;; * an optional conversion table for post-processing, or a symbol for some ;; conversion from `conversion-table' below (possibly followed by extra ;; arguments for the function), or an `ifd' symbol followed by the ifd ;; symbol name. ;; If an entry contains just one symbol/#f and `*', it is a marker that ;; says that the following belong to this ifd tag. The basic idea is that ;; tags are not unique so they need to be resolved by the current ifd, but ;; the field symbols are unique. (#f *) (#x8769 ExifIFDPointer ifd ExifIFD) ; LONG 1 (#x8825 GPSInfoIFDPointer ifd GPSInfoIFD) ; LONG 1 (ExifIFD *) (#xA005 InteroperabilityIFDPointer ifd InteroperabilityIFD) ; LONG 1 (#f *) ; TIFF Rev. 6.0 Attribute Information Used in Exif ;; * Tags relating to image data structure (#x0100 ImageWidth) ; SHORT or LONG 1 (#x0101 ImageLength) ; SHORT or LONG 1 (#x0102 BitsPerSample) ; SHORT 3 (#x0103 Compression ; SHORT 1 ((1 Uncompressed) (2 CCITT-1D) (3 Group3Fax) (4 Group4Fax) (5 LZW) (6 JPEG) (32773 PackBits))) (#x0106 PhotometricInterpretation ; SHORT 1 ((0 WhiteIsZero) (1 BlackIsZero) (2 RGB) (3 RGBPalette) (4 TransparencyMask) (5 CMYK) (6 YCbCr) (8 CIELab))) (#x0112 Orientation ; SHORT 1 ((1 (Top Left)) (2 (Top Right)) (3 (Bottom Right)) (4 (Bottom Left)) (5 (Left Top)) (6 (Right Top)) (7 (Right Bottom)) (8 (Left Bottom)))) (#x0115 SamplesPerPixel) ; SHORT 1 (#x011C PlanarConfiguration ; SHORT 1 ((1 ChunkyFormat) (2 PlanarFormat))) (#x0212 YCbCrSubSampling) ; SHORT 2 (#x0213 YCbCrPositioning ; SHORT 1 ((1 Centered) (2 Datum))) (#x011A XResolution) ; RATIONAL 1 (#x011B YResolution) ; RATIONAL 1 (#x0128 ResolutionUnit ; SHORT 1 ((1 NoUnit) (2 Inch) (3 Centimeter))) ;; * Tags relating to recording offset (#x0111 StripOffsets) ; SHORT or LONG *S (#x0116 RowsPerStrip) ; SHORT or LONG 1 (#x0117 StripByteCounts) ; SHORT or LONG *S (#x0201 JPEGInterchangeFormat) ; LONG 1 (#x0202 JPEGInterchangeFormatLength) ; LONG 1 ;; * Tags relating to image data characteristics (#x012D TransferFunction) ; SHORT 3 * 256 (#x013E WhitePoint) ; RATIONAL 2 (#x013F PrimaryChromaticities) ; RATIONAL 6 (#x0211 YCbCrCoefficients) ; RATIONAL 3 (#x0214 ReferenceBlackWhite) ; RATIONAL 6 ;; * Other tags (#x0132 DateTime ; ASCII 20 regexp-replace #rx#"^([0-9]+):([0-9]+):([0-9]+) ([0-9:]+)$" #"\\1/\\2/\\3 \\4") (#x010E ImageDescription) ; ASCII Any (#x010F Make) ; ASCII Any (#x0110 Model) ; ASCII Any (#x0131 Software) ; ASCII Any (#x013B Artist) ; ASCII Any (#x8298 Copyright) ; ASCII Any (ExifIFD *) ; Exif IFD Attribute Information ;; * Tags Relating to Version (#x9000 ExifVersion) ; UNDEFINED 4 (#xA000 FlashpixVersion) ; UNDEFINED 4 ;; * Tag Relating to Image Data Characteristics (#xA001 ColorSpace ; SHORT 1 ((1 sRGB) (#xFFFF Uncalibrated))) ;; * Tags Relating to Image Configuration (#x9101 ComponentsConfiguration ; UNDEFINED 4 undef-map ((1 Y) (2 Cb) (3 Cr) (4 R) (5 G) (6 B))) (#x9102 CompressedBitsPerPixel) ; RATIONAL 1 (#xA002 PixelXDimension) ; SHORT or LONG 1 (#xA003 PixelYDimension) ; SHORT or LONG 1 ;; * Tags Relating to User Information (#x927C MakerNote) ; UNDEFINED Any (#x9286 UserComment ; UNDEFINED Any user-comment 8) ;; * Tag Relating to Related File Information (#xA004 RelatedSoundFile) ; ASCII 13 ;; * Tags Relating to Date and Time (#x9003 DateTimeOriginal ; ASCII 20 regexp-replace #rx#"^([0-9]+):([0-9]+):([0-9]+) ([0-9:]+)$" #"\\1/\\2/\\3 \\4") (#x9004 DateTimeDigitized ; ASCII 20 regexp-replace #rx#"^([0-9]+):([0-9]+):([0-9]+) ([0-9:]+)$" #"\\1/\\2/\\3 \\4") (#x9290 SubSecTime) ; ASCII Any (#x9291 SubSecTimeOriginal) ; ASCII Any (#x9292 SubSecTimeDigitized) ; ASCII Any ;; * Tags Relating to Picture-Taking Conditions (#x829A ExposureTime) ; RATIONAL 1 (#x829D FNumber) ; RATIONAL 1 (#x8822 ExposureProgram ; SHORT 1 ((0 Undefined) (1 Manual) (2 NormalProgram) (3 AperturePriority) (4 ShutterPriority) (5 CreativeProgram) (6 ActionProgram) (7 PortraitMode) (8 LandscapeMode))) (#x8824 SpectralSensitivity) ; ASCII Any (#x8827 ISOSpeedRatings) ; SHORT Any (#x8828 OECF) ; UNDEFINED Any (#x9201 ShutterSpeedValue) ; SRATIONAL 1 (#x9202 ApertureValue) ; RATIONAL 1 (#x9203 BrightnessValue) ; SRATIONAL 1 (#x9204 ExposureBiasValue) ; SRATIONAL 1 (#x9205 MaxApertureValue) ; RATIONAL 1 (#x9206 SubjectDistance ; RATIONAL 1 subject-distance) (#x9207 MeteringMode ; SHORT 1 ((0 Unknown) (1 Average) (2 CenterWeightedAverage) (3 Spot) (4 MultiSpot) (5 MultiSegment) (6 Partial) (255 Other))) (#x9208 LightSource ; SHORT 1 ((0 Auto) (1 Daylight) (2 Fluorescent) (3 Tungsten) (4 Flash) (9 FineWeather) (10 CloudyWeather) (11 Shade) (12 DaylightFluorescent) (13 DayWhiteFluorescent) (14 CoolWhiteFluorescent) (15 WhiteFluorescent) (17 StandardLightA) (18 StandardLightB) (19 StandardLightC) (20 D55) (21 D65) (22 D75) (23 D50) (24 ISOStudioTungsten) (255 Other))) (#x9209 Flash ; SHORT 1 bits-assq ((0 1 (0 NotFired) (1 Fired)) (1 2 (2 NoStrobeDetected) (3 StrobeDetected)) (3 2 (1 CompulsoryFiring) (2 CompulsorySuppression) (3 AutoMode)) (5 1 (1 NoFlashFunction)) (6 1 (1 RedEye)))) (#x920A FocalLength) ; RATIONAL 1 (#x9214 SubjectArea) ; SHORT 2 or 3 or 4 (#xA20B FlashEnergy) ; RATIONAL 1 (#xA20C SpatialFrequencyResponse) ; UNDEFINED Any (#xA20E FocalPlaneXResolution) ; RATIONAL 1 (#xA20F FocalPlaneYResolution) ; RATIONAL 1 (#xA210 FocalPlaneResolutionUnit ; SHORT 1 ((1 NoUnit) (2 Inch) (3 Centimeter))) (#xA214 SubjectLocation) ; SHORT 2 (#xA215 ExposureIndex) ; RATIONAL 1 (#xA217 SensingMethod ; SHORT 1 ((1 Undefined) (2 OneChipColorArea) (3 TwoChipColorArea) (4 ThreeChipColorArea) (5 ColorSequentialArea) (7 Trilinear) (8 ColorSequentialLinear))) (#xA300 FileSource ; UNDEFINED 1 (("\3" DSC))) (#xA301 SceneType ; UNDEFINED 1 (("\1" DirectlyPhotographed))) (#xA302 CFAPattern) ; UNDEFINED Any (#xA401 CustomRendered ; SHORT 1 ((0 NormalProcess) (1 CustomProcess))) (#xA402 ExposureMode ; SHORT 1 ((0 AutoExposure) (1 ManualExposure) (2 AutoBracket))) (#xA403 WhiteBalance ; SHORT 1 ((0 AutoWhiteBalance) (1 ManualWhiteBalance))) (#xA404 DigitalZoomRatio) ; RATIONAL 1 (#xA405 FocalLengthIn35mmFilm) ; SHORT 1 (#xA406 SceneCaptureType ; SHORT 1 ((0 Standard) (1 Landscape) (2 Portrait) (3 NightScene))) (#xA407 GainControl ; RATIONAL 1 ((0 None) (1 LowGainUp) (2 HighGainUp) (3 LowGainDown) (4 HighGainDown))) (#xA408 Contrast ; SHORT 1 ((0 Normal) (1 Soft) (2 Hard))) (#xA409 Saturation ; SHORT 1 ((0 Normal) (1 Low saturation) (2 High saturation))) (#xA40A Sharpness ; SHORT 1 ((0 Normal) (1 Soft) (2 Hard))) (#xA40B DeviceSettingDescription) ; UNDEFINED Any (#xA40C SubjectDistanceRange ; SHORT 1 ((0 Unknown) (1 Macro) (2 CloseView) (3 DistantView))) ;; * Other Tags (#xA420 ImageUniqueID) ; ASCII 33 (InteroperabilityIFD *) ; Interoperability IFD Attribute Information ;; * Attached Information Related to Interoperability (#x0001 InteroperabilityIndex ; ASCII Any (("R98" ExifR98) (DCFThumbnail))) ;; -- others (#x0002 InteroperabilityVersion) (#x1000 RelatedImageFileFormat) (#x1001 RelatedImageWidth) (#x1002 RelatedImageLength) (GPSInfoIFD *) ; GPS Attribute Information ;; * Tags Relating to GPS (#x0000 GPSVersionID) ; BYTE 4 (#x0001 GPSLatitudeRef ; ASCII 2 (("N" North) ("S" South))) (#x0002 GPSLatitude) ; RATIONAL 3 (#x0003 GPSLongitudeRef ; ASCII 2 (("E" East) ("W" West))) (#x0004 GPSLongitude) ; RATIONAL 3 (#x0005 GPSAltitudeRef ; BYTE 1 ((0 SeaLevel) (1 SeaLevelReference))) (#x0006 GPSAltitude) ; RATIONAL 1 (#x0007 GPSTimeStamp) ; RATIONAL 3 (#x0008 GPSSatellites) ; ASCII Any (#x0009 GPSStatus ; ASCII 2 (("A" MeasurementInprogress) ("V" MeasurementInteroperability))) (#x000A GPSMeasureMode ; ASCII 2 (("2" 2-Dimensional) ("3" 3-Dimensional))) (#x000B GPSDOP) ; RATIONAL 1 (#x000C GPSSpeedRef ; ASCII 2 (("K" Kilometers/Hour) ("M" Miles/Hour) ("N" Knots))) (#x000D GPSSpeed) ; RATIONAL 1 (#x000E GPSTrackRef ; ASCII 2 (("T" TrueDirection) ("M" MagneticDirection))) (#x000F GPSTrack) ; RATIONAL 1 (#x0010 GPSImgDirectionRef ; ASCII 2 (("T" TrueDirection) ("M" MagneticDirection))) (#x0011 GPSImgDirection) ; RATIONAL 1 (#x0012 GPSMapDatum) ; ASCII Any (#x0013 GPSDestLatitudeRef ; ASCII 2 (("N" North) ("S" South))) (#x0014 GPSDestLatitude) ; RATIONAL 3 (#x0015 GPSDestLongitudeRef ; ASCII 2 (("E" East) ("W" West))) (#x0016 GPSDestLongitude) ; RATIONAL 3 (#x0017 GPSDestBearingRef ; ASCII 2 (("T" TrueDirection) ("M" MagneticDirection))) (#x0018 GPSDestBearing) ; RATIONAL 1 (#x0019 GPSDestDistanceRef ; ASCII 2 (("K" Kilometers) ("M" Miles) ("N" Knots))) (#x001A GPSDestDistance) ; RATIONAL 1 (#x001B GPSProcessingMethod ; UNDEFINED Any user-comment 1) (#x001C GPSAreaInformation) ; UNDEFINED Any (#x001D GPSDateStamp ; ASCII 11 regexp-replace #rx#"^([0-9]+):([0-9]+):([0-9]+)$" #"\\1/\\2/\\3") (#x001E GPSDifferential ; SHORT 1 ((0 NoDifferentialCorrection) (1 DifferentialCorrection))) (#f *) ; TIFF Tags (#x00FE NewSubfileType) ; LONG 1 (#x00FF SubfileType) ; SHORT 1 (#x0107 Threshholding) ; SHORT 1 (#x0108 CellWidth) ; SHORT 1 (#x0109 CellLength) ; SHORT 1 (#x010A FillOrder) ; SHORT 1 (#x010D DocumentName) ; ASCII Any (#x0118 MinSampleValue) ; SHORT SamplesPerPixel (#x0119 MaxSampleValue) ; SHORT SamplesPerPixel (#x011D PageName) ; ASCII Any (#x011E XPosition) ; RATIONAL (#x011F YPosition) ; RATIONAL (#x0120 FreeOffsets) ; LONG (#x0121 FreeByteCounts) ; LONG (#x0122 GrayResponseUnit) ; SHORT 1 (#x0123 GrayResponseCurve) ; SHORT 2**BitsPerSample (#x0124 T4Options) ; LONG 1 (#x0125 T6Options) ; LONG 1 (#x0129 PageNumber) ; SHORT 2 (#x013C HostComputer) ; ASCII Any (#x013D Predictor) ; SHORT 1 (#x0140 ColorMap) ; SHORT 3*(2**BitsPerSample) (#x0141 HalftoneHints) ; SHORT 2 (#x0142 TileWidth) ; SHORT or LONG 1 (#x0143 TileLength) ; SHORT or LONG 1 (#x0144 TileOffsets) ; LONG TilesPerImage (#x0145 TileByteCounts) ; SHORT or LONG TilesPerImage (#x014C InkSet) ; SHORT 1 (#x014D InkNames) ; ASCII Any (#x014E NumberOfInks) ; SHORT 1 (#x0150 DotRange) ; BYTE or SHORT 2, or 2*NumberOfInks (#x0151 TargetPrinter) ; ASCII Any (#x0152 ExtraSamples) ; BYTE num of extra components/pixel (#x0153 SampleFormat) ; SHORT SamplesPerPixel (#x0154 SMinSampleValue) ; Any SamplesPerPixel (#x0155 SMaxSampleValue) ; Any SamplesPerPixel (#x0156 TransferRange) ; SHORT 6 (#x0200 JPEGProc) ; SHORT 1 (#x0203 JPEGRestartInterval) ; SHORT 1 (#x0205 JPEGLosslessPredictors) ; SHORT SamplesPerPixel (#x0206 JPEGPointTransforms) ; SHORT SamplesPerPixel (#x0207 JPEGQTables) ; LONG SamplesPerPixel (#x0208 JPEGDCTables) ; LONG SamplesPerPixel (#x0209 JPEGACTables) ; LONG SamplesPerPixel (#f *) ; Misc Tags (#x014A SubIFDs ifd) ;? (#x015B JPEGTables) (#x828D CFARepeatPatternDim) (#x828E CFAPattern) (#x828F BatteryLevel) (#x83BB IPTC/NAA) (#x8773 InterColorProfile) (#x8829 Interlace) (#x882A TimeZoneOffset) (#x882B SelfTimerMode) (#x920B FlashEnergy) (#x920C SpatialFrequencyResponse) (#x920D Noise) (#x9210 FocalPlaneResolutionUnit) (#x9211 ImageNumber) (#x9212 SecurityClassification) (#x9213 ImageHistory) (#x9215 ExposureIndex) (#x9216 TIFF-EPStandardID) (#xC4A5 PrintIM) ;? (OlympusIFD *) ; Olympus MakerNote IFD (#f OlympusIFD ifd) ; dummy to identify it as an IFD (#x0200 OlympusSpecialMode ; ULONG 3 oly-special-mode) (#x0201 OlympusJpegQuality ; USHORT 1 ((1 SQ) (2 HQ) (3 SHQ))) (#x0202 OlympusMacro ; USHORT 1 ((0 Normal) (1 Macro) (2 SuperMacro))) (#x0204 OlympusDigitalZoom) ; URATIONAL 1 (#x0207 OlympusSoftwareRelease) ; ASCII 5 (#x0208 OlympusPictureInfo) ; ASCII 52 (#x0209 OlympusCameraID ; UNDEFINED 32 nul-terminated) (#X0F00 OlympusDataDump) ; ULONG 30 (CanonIFD *) ; Canon MakerNote IFD (#f CanonIFD ifd) ; dummy to identify it as an IFD (#x0006 CanonImageType) (#x0007 CanonFirmwareVersion) (#x0008 CanonImageNumber) (#x0009 CanonOwnerName) (#x000C CanonSerialNumber) (#x000F CanonCustomFunctions) )) (define (remove-suffix-nuls b) (regexp-replace #rx#"\0+$" b #"")) (define (printable? buf) (regexp-match #rx#"^[ -~]*$" buf)) (define conversion-table `((regexp-replace ,(lambda (x from to) (if (bytes? x) (regexp-replace from x to) x))) (bits-assq ,(lambda (x bits) (if (integer? x) (apply append (map (lambda (b) (cond [(assq (bitwise-and (arithmetic-shift x (- (car b))) (sub1 (expt 2 (cadr b)))) (cddr b)) => cdr] [else '()])) bits)) x))) (undef-map ,(lambda (x alist) (if (bytes? x) (map (lambda (x) (cond [(assq x alist) => cadr] [else x])) (bytes->list (remove-suffix-nuls x))) x))) (nul-terminated ,(lambda (x) (remove-suffix-nuls x))) (user-comment ,(lambda (x n) (cond [(and (bytes? x) (>= (bytes-length x) n)) (let ([encoding (remove-suffix-nuls (subbytes x 0 n))] [text (subbytes x n)]) (list (if (equal? #"" encoding) 'UndefinedText (string->symbol (bytes->string/utf-8 encoding))) (if (printable? text) (bytes->string/utf-8 text) text)))] [else x]))) (subject-distance ,(lambda (x) ;; if the numerator is #xFFFFFFFF it should be Infinity, this is the ;; best I can think of without much mess. (cond [(not (rational? x)) x] [(zero? x) 'Unknown] [(= #xFFFFFFFF (numerator x)) 'Infinity] [else x]))) (oly-special-mode ,(lambda (xs) (if (= 3 (length xs)) (list (case (car xs) [(0) 'Normal] [(1) 'Unknown] [(2) 'Fast] [(3) 'Panorama] [else (car xs)]) (list 'SequenceNumber (cadr xs)) (list 'PanoramaMode (case (caddr xs) [(1) 'LeftToRight] [(2) 'RightToLeft] [(3) 'BottomToTop] [(4) 'TopToBottom] [else (caddr xs)]))) xs)) #t))) (define exif-error (make-parameter #f)) (define tiff-data (make-parameter #f)) (define current-ifd (make-parameter #f)) (define (ifd-lookup tag) (define (unknown) ;; ((exif-error) "unknown tag value #~x" tag) (list (string->symbol (string-append "Unknown" (if (current-ifd) (format " ~a " (current-ifd)) "") (string-upcase (number->string tag 16)))))) (let ([cur (current-ifd)]) (let loop ([ts tag-table] [this #f]) (cond [(null? ts) (unknown)] [(eq? '* (cadar ts)) (loop (cdr ts) (caar ts))] ; ifd marker [(and (eq? this cur) (eq? tag (caar ts))) (cdar ts)] [else (loop (cdr ts) this)])))) (define (make-data-handler data big-end?) (define offset 0) (define stack '()) (define (subbytes0 x y) (subbytes data x y)) (define (step! n) (set! offset (+ offset n))) (define (offset! n) (set! offset n)) (define (get-offset) offset) (define (push!) (set! stack (cons offset stack))) (define (pop!) (set! offset (car stack)) (set! stack (cdr stack))) (define (get-bytes len) (begin0 (subbytes data offset (+ offset len)) (step! len))) (define (get-integer len . signed?) (if (= len 1) (let ([n (bytes-ref (get-bytes len) 0)]) (if (and (pair? signed?) (car signed?)) (- n 256) n)) (integer-bytes->integer (get-bytes len) (and (pair? signed?) (car signed?)) big-end?))) (define (get-rational len . signed?) (let ([n (apply get-integer (/ len 2) signed?)] [d (apply get-integer (/ len 2) signed?)]) (cond [(and (zero? n) (zero? d)) +nan.0] [(zero? d) (if (negative? n) -inf.0 +inf.0)] [else (/ n d)]))) (define (get-float len) (floating-point-bytes->real (get-bytes len) big-end?)) (lambda (msg . args) (apply (case msg [(subbytes) subbytes0] [(offset!) offset!] [(get-offset) get-offset] [(step!) step!] [(push!) push!] [(pop!) pop!] [(get-bytes) get-bytes] [(get-integer) get-integer] [(get-rational) get-rational] [(get-float) get-float] [else ((exif-error) "data-handler: unknown message ~s" msg)]) args))) (define (parse-data tag type size num signed?) (define data (tiff-data)) (define (parse) (apply data (case type [(undefined bytes) 'get-bytes] [(integer) 'get-integer] [(rational) 'get-rational] [(float) 'get-float]) size (if (memq type '(integer rational)) (list signed?) '()))) (when (memq type '(bytes undefined)) (set! size num) (set! num 1)) ;; save this address: in case of a nested ifd we want to ramain at the ;; pointer to it. (data 'push!) (let* ([values (let loop ([n 0] [r '()]) (if (= n num) (reverse r) (loop (add1 n) (cons (parse) r))))] [vnum (length values)] [tag-info (ifd-lookup tag)] [tag (car tag-info)]) (data 'pop!) ;; some bytes fields have #\nul as a separator (when (and (eq? type 'bytes) (= 1 vnum)) (let loop ([buf (regexp-replace #rx#"^\0+" (remove-suffix-nuls (car values)) #"")] [r '()]) (cond [(regexp-match #rx"^([^\0]*)\0+(.*)$" buf) => (lambda (x) (loop (caddr x) (cons (cadr x) r)))] [else (set! values (reverse (cons buf r))) (set! vnum (length values))]))) (cond [(and (eq? 'MakerNote tag) (= 1 vnum) (= 1 num) (bytes? (car values))) ;; save the offset since this is needed later to parse a nested IFD (list* tag (data 'get-offset) values)] [(and (= 1 vnum) (integer? (car values)) (> (length tag-info) 1) (eq? 'ifd (cadr tag-info))) (let ([ifds (parameterize ([current-ifd (and (not (null? (cddr tag-info))) (caddr tag-info))]) (data 'push!) (begin0 (parse-ifds) (data 'pop!)))]) (unless (= 1 (length ifds)) ((exif-error) "~s IFDs found for ~a (expecting 1)" (length ifds) tag)) (cons tag (car ifds)))] [else (cons tag values)]))) (define (parse-ifds . single-ifd-block?) (define data (tiff-data)) (define (parse-entry) (define tag (data 'get-integer 2)) (define-values (size type signed?) (let ([x (data 'get-integer 2)]) (cond [(assq x format-table) => (lambda (x) (values (cadr x) (caddr x) (and (memq (caddr x) '(integer rational)) (eq? (cadddr x) 's))))] [else ((exif-error) "unknown entry format #x~x" x)]))) (let* ([num (data 'get-integer 4)] [len (* num size)]) (data 'push!) (when (> len 4) (data 'offset! (data 'get-integer 4))) (begin0 (parse-data tag type size num signed?) (data 'pop!) (data 'step! 4)))) (define (parse-ifd) ;; IFD entry loop (let loop ([n (data 'get-integer 2)] [entries '()]) (if (zero? n) (reverse entries) (loop (sub1 n) (cons (parse-entry) entries))))) ;; IFD loop (if (and (pair? single-ifd-block?) (car single-ifd-block?)) (list (parse-ifd)) (let loop ([ifds '()]) (let ([offset (data 'get-integer 4)]) (if (zero? offset) (reverse ifds) (begin (data 'offset! offset) (loop (cons (parse-ifd) ifds)))))))) (define (number->human-number n) ;; Try to convert bad rationals to inexacts (if (and (rational? n) (> (denominator n) 100) (> (abs (numerator n)) 100)) (/ (round (* 1000 n)) 1000.0) n)) (define (symbol->human-string s) ;; This mess puts dashes in the "right" places, the outermost fixes cases of ;; all-caps with a small "s" in the end as in FooJPGsData (let* ([rr regexp-replace*] [s (symbol->string s)] [s (rr #rx"([A-Za-z0-9])([A-Z][a-z])" s "\\1 \\2")] [s (rr #rx"([a-z])([A-Z0-9])" s "\\1 \\2")] [s (rr #rx"(^| )([A-Z]+) ([A-Z]s)( |$)" s "\\1\\2\\3\\4")]) s)) (define (symbol->scheme-style s) (string->symbol (string-downcase (regexp-replace* #rx" " (symbol->human-string s) "-")))) (define (process-maker-note note ifd) (define data (tiff-data)) (define make (cond [(assq 'Make ifd) => cadr] [else #f])) (let ([ifd (cond [(and (regexp-match #rx"^OLYMP\0" note) (regexp-match #rx"^OLYMPUS" make)) 'OlympusIFD] [(regexp-match #rx"^Canon$" make) 'CanonIFD] [else #f])]) (parameterize ([current-ifd ifd]) (data 'step! (case ifd [(OlympusIFD) 8] [else 0])) (cons (or ifd 'MakerNote) (if ifd (car (parse-ifds #t)) (list note)))))) (define (post-process-ifd ifd) (define data (tiff-data)) (define tags (map cdr tag-table)) (let* ([img-offset (and (extract-thumbnail?) (cond [(assq 'JPEGInterchangeFormat ifd) => cdr] [else #f]))] [img-length (and img-offset (cond [(assq 'JPEGInterchangeFormatLength ifd) => cdr] [else #f]))]) (when (and img-offset (= 1 (length img-offset)) img-length (= 1 (length img-length))) (set! ifd (append ifd (list (list 'JPEG (data 'subbytes (car img-offset) (+ (car img-offset) (car img-length))))))) (when (post-process-data?) ; mark for deletion (set-car! img-offset #f) (set-car! img-length #f))) (if (post-process-data?) (let loop ([values ifd] [r '()]) (if (null? values) (reverse r) (let ([tag-info (cond [(assq (caar values) tags) => cdr] ;; for some fictitious tags like JPEG above [else '()])]) (cond [(and (not (null? (cdar values))) (not (cadar values))) (loop (cdr values) r)] ; marked for deletion [(and (eq? 'MakerNote (caar values)) (= 2 (length (cdar values))) (integer? (cadar values)) (bytes? (caddar values))) (data 'offset! (cadar values)) (loop (cons (process-maker-note (caddar values) ifd) (cdr values)) r)] [(null? tag-info) (loop (cdr values) (cons (car values) r))] [(eq? 'ifd (car tag-info)) (loop (append (cdar values) (cdr values)) r)] [(list? (car tag-info)) (loop (cdr values) (cons (cons (caar values) (map (lambda (x) (cond ((assoc x (car tag-info)) => cadr) (else x))) (cdar values))) r))] [(and (symbol? (car tag-info)) (assq (car tag-info) conversion-table)) => (lambda (convert) (define (f x) (apply (cadr convert) x (cdr tag-info))) (loop (cdr values) (cons (cons (caar values) (if (and (pair? (cddr convert)) (caddr convert)) (list (f (cdar values))) (map f (cdar values)))) r)))] [else ((exif-error) "bad value in tag-table: ~s" (car tag-info))])))) ifd))) (define (read-exif-data) (define size #f) (define data #f) (unless (equal? #"\xFF\xD8" (read-bytes 2)) ((exif-error) "not in JPEG format")) (let loop ([x (read-bytes 2)]) ; look for APP1 segment (unless (equal? #"\xFF\xE1" x) (if (and (= 2 (bytes-length x)) (equal? #xFF (bytes-ref x 0)) (not (equal? #xDA (bytes-ref x 1)))) ; stop before image data (let ([size (integer-bytes->integer (read-bytes 2) #f #t)]) (file-position (current-input-port) (+ (file-position (current-input-port)) size -2)) (loop (read-bytes 2))) ((exif-error) "not in EXIF format")))) (set! size (integer-bytes->integer (read-bytes 2) #f #t)) (unless (equal? #"Exif\0\0" (read-bytes 6)) ((exif-error) "not in EXIF format")) (set! data (read-bytes (- size 2 6))) (set! data (make-data-handler data (cond [(assoc (subbytes data 0 2) '((#"II" #f) (#"MM" #t))) => cadr] [else ((exif-error) "invalid TIFF data")]))) (parameterize ([tiff-data data]) (data 'offset! 2) (unless (= #x002A (data 'get-integer 2)) ((exif-error) "invalid TIFF data")) (let ([ifds (map (lambda (ifd) (post-process-ifd ifd)) (parse-ifds))]) (unless (= 2 (length ifds)) ((exif-error) "bad number of IFDs found (~a instead of 2)" (length ifds))) (let ([r (cons 'Image (append (car ifds) (list (cons 'Thumbnail (cadr ifds)))))]) (if (scheme-style?) (let loop ([r r]) (cond [(pair? r) (cons (loop (car r)) (loop (cdr r)))] [(symbol? r) (symbol->scheme-style r)] [else r])) r))))) (define (get-exif-data filename) (let/ec exit (define (error fmt . args) (fprintf (current-error-port) "Error in ~a: ~a.\n" filename (apply format fmt args)) (exit #f)) (unless (file-exists? filename) (error "file not found")) (parameterize ([exif-error (or (exif-error) (lambda args (close-input-port (current-input-port)) (apply error args)))]) (let ([data (with-input-from-file filename read-exif-data)]) (cons (list (car data) filename) (cdr data)))))) (define (get-exif-thumb filename) (parameterize ([scheme-style? #f] [extract-thumbnail? #t]) (let* ([data (get-exif-data filename)] [thumb (and (pair? data) (assq 'Thumbnail (cdr data)))] [thumb (and (pair? thumb) (assq 'JPEG (cdr thumb)))] [thumb (and (pair? thumb) (cadr thumb))]) (or thumb (error 'exif "No thumbnail found"))))) (define (exif-command-line . args) (cond [(and (= 1 (length args)) (vector? (car args))) (apply exif-command-line (vector->list (car args)))] [(null? args)] [(member (car args) '("-h" "--help")) (printf "usage: exif file ...\n | exif -t file\n")] [(member (car args) '("-t" "--thumbs")) (unless (= 2 (length args)) (error 'exif "thumbnail extraction should be used with one input file")) (display (get-exif-thumb (cadr args)))] [else (for-each (lambda (jpeg) ((filename-printer) jpeg) (parameterize ([scheme-style? #f] [extract-thumbnail? #f]) (define data (get-exif-data jpeg)) (if data (let loop ([data (cdr data)] [indent " "]) (unless (null? data) (let ([v (car data)]) (if (eq? (car v) 'Thumbnail) (begin (printf "~aThumbnail:\n" indent) (loop (cdr v) (string-append indent " "))) (printf "~a~a: ~a\n" indent (symbol->human-string (car v)) (let* ([v (cdr v)] [syms? (andmap symbol? v)] [v (cond [syms? (map symbol->human-string v)] [(andmap number? v) (map number->human-number v)] [(andmap (lambda (x) (and (bytes? x) (printable? x))) v) (map bytes->string/utf-8 v)] [else v])] [v (if (= 1 (length v)) (car v) v)]) (regexp-replace #rx"^\\((.*)\\)$" (format (if syms? "~a" "~s") v) "\\1"))))) (loop (cdr data) indent))) (printf " No EXIF information.\n")))) args)])) )