Commits

camlspotter  committed 48ee97b

exif support

  • Participants
  • Parent commits e36c709

Comments (0)

Files changed (9)

+open Exifutil
+
+module Numbers = struct
+  type rational = int64 * int64
+  type srational = int32 * int32
+  let float_of_rational (x,y) = Int64.to_float x /. Int64.to_float y
+  let float_of_srational (x,y) = Int32.to_float x /. Int32.to_float y
+  let string_of_rational i1 i2 = Printf.sprintf "%Ld/%Ld" i1 i2
+  let string_of_srational i1 i2 = Printf.sprintf "%ld/%ld" i1 i2
+end
+
+open Numbers
+
+module Endian = struct
+  type t = Big (* Motorola *) | Little (* Intel *)
+
+  let to_string = function
+    | Big -> "Big"
+    | Little -> "Little"
+
+  let sys = if Sys.big_endian then Big else Little
+end
+
+module IFD = struct
+  type t = 
+    | IFD_0   (** Info of the main image *)
+    | IFD_1   (** Info of the thumbnail *)
+    | EXIF    (** camera info *)
+    | GPS     (** location *)
+    | Interop (** exif format interoperability info *)
+end
+ 
+module Date = struct
+  (* for GPSDateStamp *)
+  type t = {
+    year  : int;
+    month : int; (** 1-12, I guess *)
+    day   : int;
+  }
+
+  let to_string t = Printf.sprintf "%04d:%02d:%02d"
+    t.year t.month t.day
+
+  let of_string s =
+    try
+      if String.length s <> 10 then raise Exit;
+      let check_colon n = if s.[n] <> ':' then raise Exit in
+      let get_int from len =
+        (* "0x12" is parsable, but who cares? *)
+        int_of_string (String.sub s from len )
+      in
+      check_colon 4;
+      check_colon 7;
+      let year  = get_int 0 4 in
+      let month = get_int 5 2 in
+      let day   = get_int 8 2 in
+      `Ok { year; month; day; }
+    with _ -> `Error s
+
+end
+
+module DateTime = struct
+  type t = {
+    year  : int;
+    month : int; (** 1-12, I guess *)
+    day   : int;
+    hour  : int;
+    min   : int;
+    sec   : int
+  }
+
+  let to_string t = Printf.sprintf "%04d:%02d:%02d %02d:%02d:%02d"
+    t.year t.month t.day t.hour t.min t.sec
+
+  let of_string s =
+    try
+      if String.length s <> 19 then raise Exit;
+      let check_colon n = if s.[n] <> ':' then raise Exit in
+      let get_int from len =
+        (* "0x12" is parsable, but who cares? *)
+        int_of_string (String.sub s from len )
+      in
+      check_colon 4;
+      check_colon 7;
+      check_colon 13;
+      check_colon 16;
+      let year  = get_int 0 4 in
+      let month = get_int 5 2 in
+      let day   = get_int 8 2 in
+      let hour  = get_int 11 2 in
+      let min   = get_int 14 2 in
+      let sec   = get_int 17 2 in
+      `Ok { year; month; day; hour; min; sec }
+    with _ -> `Error s
+
+  (* I had an Android phone which created DateTime tag with
+     a little endian encoded unsigned int32 of unix time!
+     This function tries to fix the issue.
+  *)
+  let of_string_packed_unix_time s =
+    try
+      let float_code c = float (Char.code c) in
+      let converter sec =
+        let open Unix in
+        let tm = Unix.gmtime sec in
+        { year  = tm.Unix.tm_year;
+          month = tm.Unix.tm_mon + 1;
+          day   = tm.Unix.tm_mday;
+          hour  = tm.Unix.tm_hour;
+          min   = tm.Unix.tm_min;
+          sec   = tm.Unix.tm_sec }
+        in
+      if s.[4] = '\000' then
+        let sec = 
+          float_code s.[0]
+          +. float_code s.[1] *. 256.0
+          +. float_code s.[2] *. 65536.0
+          +. float_code s.[3] *. 16777216.0
+        in
+        (* \000\000\000\000\000 is treated as an error 
+           rather than 1970-01-01T00:00:00
+        *)
+        if sec = 0.0 then `Error s else `Ok (converter sec)
+      else `Error s
+    with
+    | _ -> `Error s
+end
+
+module Tag = struct
+
+  type t = int
+
+  external to_string : t -> IFD.t -> string = "caml_exif_tag_get_name_in_ifd"
+end
+
+module Entry = struct
+
+  type t 
+
+  module Pack = struct
+    type format = 
+      | ILLEGAL
+      | BYTE       (*=  1, *)
+      | ASCII      (*=  2, *)
+      | SHORT      (*=  3, *)
+      | LONG       (*=  4, *)
+      | RATIONAL   (*=  5, *)
+      | SBYTE      (*=  6, *)
+      | UNDEFINED  (*=  7, *)
+      | SSHORT     (*=  8, *)
+      | SLONG      (*=  9, *)
+      | SRATIONAL  (*= 10, *)
+      | FLOAT      (*= 11, *)
+      | DOUBLE     (*= 12  *) 
+    
+    let string_of_format = function
+      | ILLEGAL -> assert false
+      | BYTE       -> "BYTE"       
+      | ASCII      -> "ASCII"      
+      | SHORT      -> "SHORT"      
+      | LONG       -> "LONG"       
+      | RATIONAL   -> "RATIONAL"   
+      | SBYTE      -> "SBYTE"      
+      | UNDEFINED  -> "UNDEFINED"  
+      | SSHORT     -> "SSHORT"     
+      | SLONG      -> "SLONG"      
+      | SRATIONAL  -> "SRATIONAL"  
+      | FLOAT      -> "FLOAT"      
+      | DOUBLE     -> "DOUBLE"     
+  
+    type unpacked = 
+      | Bytes      of int array
+      | Asciis     of string
+      | Shorts     of int array 
+      | Longs      of int64 array
+      | Rationals  of (int64 * int64) array
+      | SBytes     of int array
+      | Undefined  of string
+      | SShorts    of int array
+      | SLongs     of int32 array
+      | SRationals of (int32 * int32) array
+      | Floats     of float array
+      | Doubles    of float array
+  
+    external decode_bytes      : string -> int -> int array       = "Val_ExifBytes"
+    external decode_shorts     : string -> int -> int array       = "Val_ExifShorts"
+    external decode_longs      : string -> int -> int64 array     = "Val_ExifLongs"
+    external decode_rationals  : string -> int -> rational array  = "Val_ExifRationals"
+    external decode_sbytes     : string -> int -> int array       = "Val_ExifSBytes"
+    external decode_sshorts    : string -> int -> int array       = "Val_ExifSShorts"
+    external decode_slongs     : string -> int -> int32 array     = "Val_ExifSLongs"
+    external decode_srationals : string -> int -> srational array = "Val_ExifSRationals"
+    external decode_floats     : string -> int -> float array     = "Val_ExifFloats"
+    external decode_doubles    : string -> int -> float array     = "Val_ExifDoubles"
+    
+    let unpack format components content =
+      match format with
+      | ILLEGAL -> assert false
+      | BYTE       (*=  1, *) -> 
+          Bytes (decode_bytes content components)
+      | ASCII      (*=  2, *) -> 
+          (* remove the last \000 *)
+          let content = 
+            let len = String.length content in
+            if content.[len-1] = '\000' then
+              String.sub content 0 (len-1)
+            else content
+          in
+          Asciis content
+      | SHORT      (*=  3, *) -> 
+          Shorts (decode_shorts content components)
+      | LONG       (*=  4, *) ->
+          Longs (decode_longs content components)
+      | RATIONAL   (*=  5, *) ->
+          Rationals (decode_rationals content components)
+      | SBYTE      (*=  6, *) -> 
+          Bytes (decode_sbytes content components)
+      | UNDEFINED  (*=  7, *) -> Undefined content
+      | SSHORT     (*=  8, *) ->
+          SShorts (decode_sshorts content components)
+      | SLONG      (*=  9, *) ->
+          SLongs (decode_slongs content components)
+      | SRATIONAL  (*= 10, *) ->
+          SRationals (decode_srationals content components)
+      | FLOAT      (*= 11, *) ->
+          Floats (decode_floats content components)
+      | DOUBLE     (*= 12  *) ->
+          Doubles (decode_doubles content components)
+  
+    open Format
+  
+    let format ppf v = 
+      begin match v with
+      | Asciis     _ -> () 
+      | Undefined  _ -> fprintf ppf "Undefined "
+      | Bytes      _ -> fprintf ppf "Bytes "
+      | SBytes     _ -> fprintf ppf "SBytes "
+      | Shorts     _ -> fprintf ppf "Shorts "
+      | Longs      _ -> fprintf ppf "Longs "
+      | Rationals  _ -> fprintf ppf "Rationals "
+      | SShorts    _ -> fprintf ppf "SShorts "
+      | SLongs     _ -> fprintf ppf "SLongs "
+      | SRationals _ -> fprintf ppf "SRationals "
+      | Floats     _ -> fprintf ppf "Floats "
+      | Doubles    _ -> ()
+      end;
+      match v with
+      | Asciis     s 
+      | Undefined  s -> fprintf ppf "%S" s
+      | Bytes      is
+      | SBytes     is
+      | Shorts     is -> Format.array (fun ppf -> fprintf ppf "%d") ppf is
+      | Longs      is -> Format.array (fun ppf -> fprintf ppf "%Ld") ppf is
+      | Rationals  rs -> Format.array (fun ppf (i1,i2) -> fprintf ppf "%Ld/%Ld" i1 i2) ppf rs
+      | SShorts    is -> Format.array (fun ppf -> fprintf ppf "%d") ppf is
+      | SLongs     is -> Format.array (fun ppf -> fprintf ppf "%ld") ppf is
+      | SRationals  rs -> Format.array (fun ppf (i1,i2) -> fprintf ppf "%ld/%ld" i1 i2) ppf rs
+      | Floats     fs
+      | Doubles    fs -> Format.array (fun ppf -> fprintf ppf "%.20g") ppf fs
+  
+  end
+
+  external unref : t -> unit = "caml_exif_entry_unref"
+
+  module Decoded = struct
+    type t = {
+      tag : int;
+      format : Pack.format;
+      components : int; (* hope it will not overflow *)
+      data : string;
+    }
+
+  end
+
+  external decode : t -> Decoded.t = "caml_exif_decode_entry"
+
+  type unpacked_entry = Tag.t * Pack.unpacked
+
+  let unpack : Decoded.t -> unpacked_entry = fun d ->
+    d.Decoded.tag,
+    Pack.unpack d.Decoded.format d.Decoded.components d.Decoded.data
+
+  let format_unpacked_entry ifd ppf (tag, p) =
+    Format.fprintf ppf "%s(%x): %a"
+      (Tag.to_string tag ifd) tag
+      Pack.format p
+
+  let format ifd ppf t =
+    format_unpacked_entry ifd ppf (unpack (decode t))
+
+end
+
+module Content = struct
+  type t
+
+  external unref : t -> unit = "caml_exif_content_unref"
+
+  external entries : t -> Entry.t list = "caml_exif_content_entries"
+
+  let entries t = 
+    let es = entries t in
+    let finalise v =
+      Gc.finalise (fun v -> 
+        Entry.unref v) v
+    in
+    List.iter finalise es;
+    es
+
+  let format ifd ppf t =
+    let ents = entries t in
+    Format.fprintf ppf "@[[ @[%a@] ]@]"
+      (Format.list ";@ " (Entry.format ifd)) ents
+    
+end
+
+module Data = struct
+  type t
+
+  external from_string : string -> t = "caml_val_exif_data"
+  external unref : t -> unit = "caml_exif_data_unref"
+
+  external get_byte_order : t -> Endian.t = "caml_exif_get_byte_order"
+  external set_byte_order : t -> Endian.t -> unit = "caml_exif_set_byte_order"
+  external fix : t -> unit = "caml_exif_data_fix"
+  external dump : t -> unit = "caml_exif_data_dump"
+
+  let from_string data = 
+    let t = from_string data in
+    set_byte_order t Endian.sys ; (* Destructively fix the endianess *)
+    Gc.finalise (fun v -> 
+      unref v) t;
+    t
+      
+  type contents = {
+    ifd_0   : Content.t option;
+    ifd_1   : Content.t option;
+    exif    : Content.t option;
+    gps     : Content.t option;
+    interop : Content.t option
+  }
+
+  external contents : t -> contents = "caml_exif_data_contents"
+
+  let contents t = 
+    let cs = contents t in
+    let finalise = function
+      | None -> ()
+      | Some v -> 
+          Gc.finalise (fun v -> 
+            Content.unref v) v
+    in
+    finalise cs.ifd_0;
+    finalise cs.ifd_1;
+    finalise cs.exif;
+    finalise cs.gps;
+    finalise cs.interop;
+    cs
+
+  let get_ifd_0    t = (contents t).ifd_0 
+  let get_ifd_1    t = (contents t).ifd_1
+  let get_exif     t = (contents t).exif
+  let get_gps      t = (contents t).gps
+  let get_interop  t = (contents t).interop
+
+  let unpack_gen f t = match f t with
+    | None -> None
+    | Some content ->
+        Some (List.map (fun x -> Entry.unpack (Entry.decode x))
+                (Content.entries content))
+
+  let unpack_ifd_0   = unpack_gen get_ifd_0
+  let unpack_ifd_1   = unpack_gen get_ifd_1
+  let unpack_exif    = unpack_gen get_exif
+  let unpack_gps     = unpack_gen get_gps
+  let unpack_interop = unpack_gen get_interop
+
+  open Format
+
+  let format ppf t =
+    let conts = contents t in
+    fprintf ppf "{ @[ifd_0=%a;@ ifd_1=%a;@ exif=%a;@ gps=%a;@ inter=%a@] }"
+      (Format.opt (Content.format IFD.IFD_0)  ) conts.ifd_0
+      (Format.opt (Content.format IFD.IFD_1)  ) conts.ifd_1
+      (Format.opt (Content.format IFD.EXIF)   ) conts.exif
+      (Format.opt (Content.format IFD.GPS)    ) conts.gps
+      (Format.opt (Content.format IFD.Interop)) conts.interop
+    
+end
+
+
+module Analyze = struct
+  (* Exif data analyzer 
+  
+     Due to its updated-on-demand and lots-of-tags nature,
+     This module is implemented in a separate file from exif.ml
+     and its interface file is auto created.
+  *)
+  
+  open Numbers
+  open IFD
+  open Entry.Pack
+  
+  type datetime = 
+    [ `EncodedInUnixTime of DateTime.t
+    | `Error of string
+    | `Ok of DateTime.t 
+    ]
+  (** I have some photos from my old Android with non Ascii datetime.
+      They have encoded 32 bit int in Unix time instead! :-(
+  *)
+
+  let parse_datetime s =
+    match DateTime.of_string s with
+    | (`Ok _ as r) -> r
+    | `Error s -> 
+        match DateTime.of_string_packed_unix_time s with
+        | `Ok v -> `EncodedInUnixTime v
+        | (`Error _ as e) -> e 
+
+  let analyze_ifd (tag, pack) = match tag, pack with
+      
+    | 0x10f, Asciis s -> `Make s
+    | 0x110, Asciis s -> `Model s
+    | 0x112, Shorts [| 1 |] -> `Orientation `TopLeft
+    | 0x112, Shorts [| 2 |] -> `Orientation `TopRight
+    | 0x112, Shorts [| 3 |] -> `Orientation `BottomRight
+    | 0x112, Shorts [| 4 |] -> `Orientation `BottomLeft
+    | 0x112, Shorts [| 5 |] -> `Orientation `LeftTop
+    | 0x112, Shorts [| 6 |] -> `Orientation `RightTop
+    | 0x112, Shorts [| 7 |] -> `Orientation `RightBottom
+    | 0x112, Shorts [| 8 |] -> `Orientation `LeftBottom
+    | 0x11a, Rationals [| r |] -> `XResolution r
+    | 0x11b, Rationals [| r |] -> `YResolution r
+    | 0x128, Shorts [| 2 |] -> `ResolutionUnit `Inches
+    | 0x128, Shorts [| 3 |] -> `ResolutionUnit `Centimeters
+    | 0x131, s -> `Software s
+    | 0x132, Asciis s -> `DateTime (parse_datetime s)
+    | _ -> `Unknown (tag, pack)
+  
+  let analyze_exif (tag, pack) = match tag, pack with
+  
+    | 0x9000, Undefined s -> `ExifVersion s
+    | 0x927c, Undefined s -> `MakerNote s
+    | 0x9286, Undefined s -> `UserComment s
+        (* The first 8 bytes indicate char code:
+           ASCII 41.H, 53.H, 43.H, 49.H, 49.H, 00.H, 00.H, 00.H 
+           JIS   4A.H, 49.H, 53.H, 00.H, 00.H, 00.H, 00.H, 00.H JIS X0208-1990
+           Unicode 55.H, 4E.H, 49.H, 43.H, 4F.H, 44.H, 45.H, 00.H Unicode Standard
+           Undefined 00.H, 00.H, 00.H, 00.H, 00.H, 00.H, 00.H, 00.H          
+        *)
+    | 0x9003, Asciis s -> `DateTimeOriginal (parse_datetime s)
+    | 0x9004, Asciis s -> `DateTimeDigitized (parse_datetime s)
+    | 0x9290, Asciis s -> `SubsecTime s
+    | 0x9291, Asciis s -> `SubsecTimeOriginal s
+    | 0x9292, Asciis s -> `SubsecTimeDigitized s
+  
+    | _ -> `Unknown (tag, pack)
+  
+  module GPS = struct
+    type latitude = [ `North | `South ] * rational
+    type longitude = [ `East | `West ] * rational
+    type altitude = [ `AboveSeaLevel | `BelowSeaLevel ] * rational
+    type time_stamp_utc = { 
+      hour : rational;
+      min  : rational;
+      sec  : rational; 
+    }
+    type direction = [ `True | `Magnetic ] * rational
+    type map_datum = string
+  
+    type t = {
+      version        : (int * int * int * int) option;
+      latitude       : latitude option;
+      longitude      : longitude option;
+      altitude       : altitude option;
+      time_stamp_utc : time_stamp_utc option;
+      direction      : direction option;
+      map_datum      : map_datum option
+    }
+  end
+        
+  let analyze_gps (tag, v) = match tag, v with
+      
+    | 00, Bytes [|x;y;z;w|] -> `GPSVersion (x,y,z,w)
+    | 01, Asciis "N" -> `NorthLatitude
+    | 01, Asciis "S" -> `SouthLatitude
+    | 02, Rationals [|r|] -> `Latitude r
+    | 03, Asciis "E" -> `EastLongitude
+    | 03, Asciis "W" -> `WestLongitude
+    | 04, Rationals [|r|] -> `Longitude r
+    | 05, Bytes [|0|] -> `AboveSeaLevel
+    | 05, Bytes [|1|] -> `BelowSeaLevel
+    | 06, Rationals [|r|] -> `Altitude r
+    | 07, Rationals [|h;m;s|] -> 
+        `TimeStampUTC (float_of_rational h,
+                       float_of_rational m,
+                       float_of_rational s)
+    | 07, SRationals [|h;m;s|] -> 
+        (* It is illegal in the spec but I see some photos with SRationals *)
+        `TimeStampUTCinSRationals (float_of_srational h,
+                                   float_of_srational m,
+                                   float_of_srational s) 
+  
+    | 16, Asciis "T" -> `ImgDirectionTrue
+    | 16, Asciis "M" -> `ImgDirectionMagnetic
+    | 17, Rationals [|r|] -> `ImgDirection r
+    | 18, Asciis s -> `GPSMapDatum s
+    | 29, Asciis s -> `GPSDate (Date.of_string s)
+  
+    | _ -> `Unknown (tag, v)
+  
+  
+  let exif_datetime t = match Data.unpack_exif t with
+    | Some entries -> 
+        List.find_map_opt (function
+          | `DateTimeOriginal t -> Some t
+          | _ -> None)
+          (List.map analyze_exif entries)
+    | None -> None
+  
+  let ifd_0_datetime t = match Data.unpack_ifd_0 t with
+    | Some entries -> 
+        List.find_map_opt (function
+          | `DateTime t -> Some t
+          | _ -> None)
+          (List.map analyze_ifd entries)
+    | None -> None
+  
+  let datetime t = match exif_datetime t with
+    | (Some _ as res) -> res
+    | None -> ifd_0_datetime t
+end

File src/exif.mli

+module Numbers : sig
+  type rational  = int64 * int64 (** unsigned 32bits int rational *)
+  type srational = int32 * int32 (** signed 32bits int rational *)
+  val float_of_rational   : int64 * int64 -> float
+  val float_of_srational  : int32 * int32 -> float
+  val string_of_rational  : int64 -> int64 -> string
+  val string_of_srational : int32 -> int32 -> string
+end
+
+open Numbers
+
+module Endian : sig
+  type t = Big | Little 
+  val to_string : t -> string 
+  val sys : t 
+end
+
+module IFD : sig
+  type t = 
+    | IFD_0   (** Info of the main image *)
+    | IFD_1   (** Info of the thumbnail *)
+    | EXIF    (** camera info *)
+    | GPS     (** location *)
+    | Interop (** exif format interoperability info *)
+end
+
+module Date : sig
+  (** Date for GPSDateStamp *)
+  type t = { year : int; month : int; day : int; }
+  val to_string : t -> string
+  val of_string : string -> [> `Error of string | `Ok of t ]
+end
+
+module DateTime : sig
+  type t = {
+    year : int;
+    month : int;
+    day : int;
+    hour : int;
+    min : int;
+    sec : int;
+  }
+
+  val to_string : t -> string
+
+  val of_string : string -> [> `Error of string | `Ok of t ]
+  (** To convert DateTime string to DateTime.t.
+  *)
+
+  val of_string_packed_unix_time : string -> [> `Error of string | `Ok of t ]
+  (** I had an Android phone which created DateTime tag with
+      a little endian encoded unsigned int32 of unix time!
+      This function tries to fix the issue.
+  *)
+  
+end
+    
+module Tag : sig
+  type t = int
+
+  val to_string : t -> IFD.t -> string
+  (** Tag name requires IFD.t since the same tag number has different
+      meaning in IFD and GPS *)
+end
+
+module Entry : sig
+  type t
+  
+  module Pack : sig
+
+    type format =
+      | ILLEGAL (** do not used it *)
+      | BYTE
+      | ASCII
+      | SHORT
+      | LONG
+      | RATIONAL
+      | SBYTE
+      | UNDEFINED
+      | SSHORT
+      | SLONG
+      | SRATIONAL
+      | FLOAT
+      | DOUBLE
+
+    val string_of_format : format -> string
+
+    type unpacked =
+      | Bytes of int array
+      | Asciis of string
+      | Shorts of int array
+      | Longs of int64 array
+      | Rationals of (int64 * int64) array
+      | SBytes of int array
+      | Undefined of string
+      | SShorts of int array
+      | SLongs of int32 array
+      | SRationals of (int32 * int32) array
+      | Floats of float array
+      | Doubles of float array
+    (** Constructors start with "S" are signed. *)
+
+    val unpack : format -> int -> string -> unpacked
+    (** [unpack format components packed] 
+        [components] are the number of elements in [packed],
+        not the bytes of [packed].
+    *)
+
+    val format : Format.formatter -> unpacked -> unit
+
+  end
+  
+  module Decoded : sig
+    type t = {
+      tag : int;
+      format : Pack.format;
+      components : int;
+      data : string;
+    }
+  end
+  
+  val decode : t -> Decoded.t
+
+  type unpacked_entry = Tag.t * Pack.unpacked
+  val unpack : Decoded.t -> unpacked_entry
+
+  val format_unpacked_entry :
+    IFD.t -> Exifutil.Format.formatter -> Tag.t * Pack.unpacked -> unit
+  
+  val format : IFD.t -> Exifutil.Format.formatter -> t -> unit
+    (** [format] does decode + unpack *)
+
+end
+
+module Content : sig
+  type t
+
+  val entries : t -> Entry.t list
+  val format : IFD.t -> Exifutil.Format.formatter -> t -> unit
+end
+
+module Data : sig
+  type t
+  
+  val get_byte_order : t -> Endian.t
+  val set_byte_order : t -> Endian.t -> unit
+  val fix : t -> unit
+  val dump : t -> unit
+
+  val from_string : string -> t
+  val format : Exifutil.Format.formatter -> t -> unit
+  
+  type contents = {
+    ifd_0   : Content.t option;
+    ifd_1   : Content.t option;
+    exif    : Content.t option;
+    gps     : Content.t option;
+    interop : Content.t option;
+  }
+  
+  val contents : t -> contents
+
+  val get_ifd_0   : t -> Content.t option
+  val get_ifd_1   : t -> Content.t option
+  val get_exif    : t -> Content.t option
+  val get_gps     : t -> Content.t option
+  val get_interop : t -> Content.t option
+
+  val unpack_ifd_0 : t -> Entry.unpacked_entry list option
+  val unpack_ifd_1 : t -> Entry.unpacked_entry list option
+  val unpack_exif  : t -> Entry.unpacked_entry list option
+  val unpack_gps   : t -> Entry.unpacked_entry list option
+  val unpack_interop : t -> Entry.unpacked_entry list option
+
+end
+
+module Analyze : sig
+
+  type datetime = 
+    [ `EncodedInUnixTime of DateTime.t
+    | `Error of string
+    | `Ok of DateTime.t 
+    ]
+  (** I have some photos from my old Android with non Ascii datetime.
+      They have encoded 32 bit int in Unix time instead! :-(
+  *)
+
+  val parse_datetime : string -> [> datetime ]
+
+  val analyze_ifd :
+    int * Entry.Pack.unpacked 
+    -> [> `DateTime of [> datetime ]
+       | `Make of string
+       | `Model of string
+       | `Orientation of [> `BottomLeft
+                         | `BottomRight
+                         | `LeftBottom
+                         | `LeftTop
+                         | `RightBottom
+                         | `RightTop
+                         | `TopLeft
+                         | `TopRight ]
+       | `ResolutionUnit of [> `Centimeters | `Inches ]
+       | `Software of Entry.Pack.unpacked
+       | `Unknown of int * Entry.Pack.unpacked
+       | `XResolution of int64 * int64
+    | `YResolution of int64 * int64 ]
+
+  val analyze_exif :
+    int * Entry.Pack.unpacked 
+    -> [> `DateTimeDigitized of [> datetime ]
+       | `DateTimeOriginal of [> datetime ]
+       | `ExifVersion of string
+       | `MakerNote of string
+       | `SubsecTime of string
+       | `SubsecTimeDigitized of string
+       | `SubsecTimeOriginal of string
+       | `Unknown of int * Entry.Pack.unpacked
+       | `UserComment of string ]
+
+  val analyze_gps :
+    int * Entry.Pack.unpacked 
+    -> [> `AboveSeaLevel
+       | `Altitude of int64 * int64
+       | `BelowSeaLevel
+       | `EastLongitude
+       | `GPSDate of [> `Error of string | `Ok of Date.t ]
+       | `GPSMapDatum of string
+       | `GPSVersion of int * int * int * int
+       | `ImgDirection of int64 * int64
+       | `ImgDirectionMagnetic
+       | `ImgDirectionTrue
+       | `Latitude of int64 * int64
+       | `Longitude of int64 * int64
+       | `NorthLatitude
+       | `SouthLatitude
+       | `TimeStampUTC of float * float * float
+       | `TimeStampUTCinSRationals of float * float * float
+       | `Unknown of int * Entry.Pack.unpacked
+       | `WestLongitude 
+       ]
+
+  val ifd_0_datetime : Data.t -> [> datetime ] option
+  (** Get ifd_0 DateTime *)
+
+  val exif_datetime : Data.t -> [> datetime ] option
+  (** Get exif DateTimeOriginal *)
+
+  val datetime : Data.t -> [> datetime ] option
+  (** Get one of the first finding of the followings:
+      * exif DateTimeOriginal
+      * ifd_0 DateTime
+   *)
+end

File src/exif_c.c

+/***********************************************************************/
+/*                                                                     */
+/*                           CamlImages                                */
+/*                                                                     */
+/*                          Jun Furuse                                 */
+/*                                                                     */
+/*  Copyright 1999-2013                                                */
+/*  Institut National de Recherche en Informatique et en Automatique.  */
+/*  Distributed only by permission.                                    */
+/*                                                                     */
+/***********************************************************************/
+
+#ifdef HAVE_CONFIG_H
+#include "config.h"
+#endif
+
+#include <stdio.h>
+#include <string.h>
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/callback.h>
+#include <caml/fail.h>
+
+#include <libexif/exif-byte-order.h>
+#include <libexif/exif-data-type.h>
+#include <libexif/exif-ifd.h>
+#include <libexif/exif-log.h>
+#include <libexif/exif-tag.h>
+#include <libexif/exif-content.h>
+#include <libexif/exif-mnote-data.h>
+#include <libexif/exif-mem.h>
+
+value Val_ExifBytes(unsigned char *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal1(res);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,Val_int(p[i]));
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifSBytes(signed char *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal1(res);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,Val_int(p[i]));
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifShorts(unsigned short *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal1(res);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,Val_int(p[i]));
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifSShorts(short *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal1(res);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,Val_int(p[i]));
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifLongs(unsigned long *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal1(res);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,caml_copy_int64(p[i]) /* too big... */ );
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifSLongs(long *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal1(res);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,caml_copy_int32(p[i]) /* too big... */ );
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifRationals(unsigned long *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal2(res,tmp);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        tmp = alloc(2,0);
+        Store_field(tmp,0, caml_copy_int64(p[i*2]) /* too big... */ );
+        Store_field(tmp,1, caml_copy_int64(p[i*2+1]) /* too big... */ );
+        Store_field(res,i, tmp);
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifSRationals(long *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal2(res,tmp);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        tmp = alloc(2,0);
+        Store_field(tmp,0,caml_copy_int32(p[i*2]) /* too big... */ );
+        Store_field(tmp,1,caml_copy_int32(p[i*2]+1) /* too big... */ );
+        Store_field(res,i,tmp);
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifFloats(float *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal2(res,tmp);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i,caml_copy_double(p[i]));
+    }
+    CAMLreturn(res);
+}
+
+value Val_ExifDoubles(double *p, value vsize)
+{
+    CAMLparam0();
+    CAMLlocal2(res,tmp);
+    int i;
+    res = alloc(Int_val(vsize),0);
+    for(i=0; i<Int_val(vsize); i++){
+        Store_field(res,i, caml_copy_double(p[i]));
+    }
+    CAMLreturn(res);
+}
+
+value caml_exif_tag_get_name_in_ifd(value tag, value ifd)
+{
+    return caml_copy_string(exif_tag_get_name_in_ifd(Int_val(tag), Int_val(ifd)));
+}
+
+//////////
+
+
+value caml_val_exif_data(value string)
+{
+    CAMLparam1(string);
+    CAMLlocal1(res);
+    ExifData *data = exif_data_new_from_data(String_val(string), 
+                                             caml_string_length(string));
+
+    if( !data ){ failwith("exif_data_new_from_data"); }
+
+    // exif_data_free(data);
+
+    //fprintf(stderr, "data=%x\n", data);
+    res = alloc_small(1,0);
+    Field(res,0) = (value)data;
+
+    CAMLreturn(res);
+}
+
+void caml_exif_set_byte_order(value data, value order)
+{
+    exif_data_set_byte_order((ExifData *)Field(data, 0), Int_val(order));
+}
+
+value caml_exif_get_byte_order(value data)
+{
+    CAMLparam1(data);
+    CAMLreturn(Val_int(exif_data_get_byte_order((ExifData *)Field(data, 0))));
+}
+
+void caml_exif_data_fix(value data)
+{
+    exif_data_fix((ExifData *)Field(data, 0));
+}
+
+void caml_exif_data_unref(value data)
+{
+    exif_data_unref((ExifData*)Field(data, 0));
+}
+ 
+void caml_exif_data_dump(value data)
+{
+    exif_data_dump((ExifData*)Field(data, 0));
+}
+
+value caml_exif_data_contents(value vdata)
+{
+    CAMLparam1(vdata);
+    CAMLlocal3(res, tmp, tmp2);
+    int i;
+    ExifData *data = (ExifData*)Field(vdata,0);
+    //fprintf(stderr, "data=%x\n", data);
+    res = alloc_tuple(EXIF_IFD_COUNT);
+    for(i=0; i< EXIF_IFD_COUNT; i++){
+        ExifContent *p = data->ifd[i];
+        if( p ){ 
+            exif_content_ref(p);
+            tmp = alloc_small(1,0);
+            Field(tmp,0) = (value)p;
+            tmp2 = alloc_small(1,0);
+            //fprintf(stderr, "content=%x (count=%d)\n", p, p->count);
+            Field(tmp2,0) = tmp;
+            Store_field(res,i,tmp2);
+        } else {
+            Store_field(res,i,Val_int(0));
+        }
+    }
+    CAMLreturn(res);
+}
+
+void caml_exif_content_unref(value vdata)
+{
+    ExifContent *c = (ExifContent*)Field(vdata,0);
+    exif_content_unref(c);
+}
+
+value caml_exif_content_entries(value vdata)
+{
+    CAMLparam1(vdata);
+    CAMLlocal3(res, tmp, tmp2);
+    int i;
+    ExifContent *c = (ExifContent *)Field(vdata,0);
+    //fprintf(stderr, "content=%x (count=%d)\n", c, c->count);
+    res = Val_int(0); // null
+    for(i=c->count-1; i>=0; i--){
+        ExifEntry *e = c->entries[i];
+        if( e ){ 
+            exif_entry_ref(e);
+            
+            // boxing
+            tmp = alloc_small(1,0);
+            Field(tmp,0) = (value)e;
+
+            // cons
+            tmp2 = alloc_small(2,0);
+            Field(tmp2,0) = tmp;
+            Field(tmp2,1) = res;
+
+            // rewire
+            res = tmp2;
+        }
+    }
+    CAMLreturn(res);
+}
+
+void caml_exif_entry_unref(value vdata)
+{
+    ExifEntry *c = (ExifEntry*)Field(vdata,0);
+    exif_entry_unref(c);
+}
+
+value caml_exif_decode_entry(value vdata)
+{
+    CAMLparam1(vdata);
+    CAMLlocal1(tpl);
+    ExifEntry *p = (ExifEntry *)Field(vdata,0);
+
+    tpl = alloc_tuple(4);
+    Store_field(tpl,0,Val_int(p->tag));
+    Store_field(tpl,1,Val_int(p->format));
+    Store_field(tpl,2,Val_int(p->components)); // hope it never overflow...
+    Store_field(tpl,3,alloc_string(p->size));
+    memcpy(String_val(Field(tpl,3)), p->data, p->size);
+    CAMLreturn(tpl);
+}

File src/exif_na.c

+/***********************************************************************/
+/*                                                                     */
+/*                           CamlImages                                */
+/*                                                                     */
+/*                          Jun Furuse                                 */
+/*                                                                     */
+/*  Copyright 1999-2013                                                */
+/*  Institut National de Recherche en Informatique et en Automatique.  */
+/*  Distributed only by permission.                                    */
+/*                                                                     */
+/***********************************************************************/
+
+#include <caml/mlvalues.h>
+#include <caml/alloc.h>
+#include <caml/memory.h>
+#include <caml/fail.h>
+
+#define NA(x) value x(){ failwith("unsupported"); }
+
+NA(Val_ExifBytes)
+NA(Val_ExifSBytes)
+NA(Val_ExifShorts)
+NA(Val_ExifSShorts)
+NA(Val_ExifLongs)
+NA(Val_ExifSLongs)
+NA(Val_ExifRationals)
+NA(Val_ExifSRationals)
+NA(Val_ExifFloats)
+NA(Val_ExifDoubles)
+NA(caml_exif_tag_get_name_in_ifd)
+NA(caml_val_exif_data)
+NA(caml_exif_set_byte_order)
+NA(caml_exif_get_byte_order)
+NA(caml_exif_data_fix)
+NA(caml_exif_data_unref)
+NA(caml_exif_data_dump)
+NA(caml_exif_data_contents)
+NA(caml_exif_content_unref)
+NA(caml_exif_content_entries)
+NA(caml_exif_entry_unref)
+NA(caml_exif_decode_entry)

File src/exifanalyze.ml

+(* Exif data analyzer 
+
+   Due to its updated-on-demand and lots-of-tags nature,
+   This module is implemented in a separate file from exif.ml
+   and its interface file is auto created.
+*)
+
+open Exifutil
+
+open Exif
+open Exif.Numbers
+open Exif.IFD
+open Exif.Entry.Pack
+
+(* I have some photos from my old Android with non Ascii datetime.
+   They have encoded 32 bit int in Unix time instead! :-(
+*)
+let analyze_datetime s =
+  match DateTime.of_string s with
+  | (`Ok _ as r) -> r
+  | `Error s -> 
+      match DateTime.of_string_packed_unix_time s with
+      | `Ok v -> `EncodedInUnixTime v
+      | (`Error _ as e) -> e 
+
+let analyze_ifd (tag, pack) = match tag, pack with
+    
+  | 0x10f, Asciis s -> `Make s
+  | 0x110, Asciis s -> `Model s
+  | 0x112, Shorts [| 1 |] -> `Orientation `TopLeft
+  | 0x112, Shorts [| 2 |] -> `Orientation `TopRight
+  | 0x112, Shorts [| 3 |] -> `Orientation `BottomRight
+  | 0x112, Shorts [| 4 |] -> `Orientation `BottomLeft
+  | 0x112, Shorts [| 5 |] -> `Orientation `LeftTop
+  | 0x112, Shorts [| 6 |] -> `Orientation `RightTop
+  | 0x112, Shorts [| 7 |] -> `Orientation `RightBottom
+  | 0x112, Shorts [| 8 |] -> `Orientation `LeftBottom
+  | 0x11a, Rationals [| r |] -> `XResolution r
+  | 0x11b, Rationals [| r |] -> `YResolution r
+  | 0x128, Shorts [| 2 |] -> `ResolutionUnit `Inches
+  | 0x128, Shorts [| 3 |] -> `ResolutionUnit `Centimeters
+  | 0x131, s -> `Software s
+  | 0x132, Asciis s -> `DateTime (analyze_datetime s)
+  | _ -> `Unknown (tag, pack)
+
+let analyze_exif (tag, pack) = match tag, pack with
+
+  | 0x9000, Undefined s -> `ExifVersion s
+  | 0x927c, Undefined s -> `MakerNote s
+  | 0x9286, Undefined s -> `UserComment s
+      (* The first 8 bytes indicate char code:
+         ASCII 41.H, 53.H, 43.H, 49.H, 49.H, 00.H, 00.H, 00.H 
+         JIS   4A.H, 49.H, 53.H, 00.H, 00.H, 00.H, 00.H, 00.H JIS X0208-1990
+         Unicode 55.H, 4E.H, 49.H, 43.H, 4F.H, 44.H, 45.H, 00.H Unicode Standard
+         Undefined 00.H, 00.H, 00.H, 00.H, 00.H, 00.H, 00.H, 00.H          
+      *)
+  | 0x9003, Asciis s -> `DateTimeOriginal (analyze_datetime s)
+  | 0x9004, Asciis s -> `DateTimeDigitized (analyze_datetime s)
+  | 0x9290, Asciis s -> `SubsecTime s
+  | 0x9291, Asciis s -> `SubsecTimeOriginal s
+  | 0x9292, Asciis s -> `SubsecTimeDigitized s
+
+  | _ -> `Unknown (tag, pack)
+
+module GPS = struct
+  type latitude = [ `North | `South ] * rational
+  type longitude = [ `East | `West ] * rational
+  type altitude = [ `AboveSeaLevel | `BelowSeaLevel ] * rational
+  type time_stamp_utc = { 
+    hour : rational;
+    min  : rational;
+    sec  : rational; 
+  }
+  type direction = [ `True | `Magnetic ] * rational
+  type map_datum = string
+
+  type t = {
+    version        : (int * int * int * int) option;
+    latitude       : latitude option;
+    longitude      : longitude option;
+    altitude       : altitude option;
+    time_stamp_utc : time_stamp_utc option;
+    direction      : direction option;
+    map_datum      : map_datum option
+  }
+end
+      
+let analyze_gps (tag, v) = match tag, v with
+    
+  | 00, Bytes [|x;y;z;w|] -> `GPSVersion (x,y,z,w)
+  | 01, Asciis "N" -> `NorthLatitude
+  | 01, Asciis "S" -> `SouthLatitude
+  | 02, Rationals [|r|] -> `Latitude r
+  | 03, Asciis "E" -> `EastLongitude
+  | 03, Asciis "W" -> `WestLongitude
+  | 04, Rationals [|r|] -> `Longitude r
+  | 05, Bytes [|0|] -> `AboveSeaLevel
+  | 05, Bytes [|1|] -> `BelowSeaLevel
+  | 06, Rationals [|r|] -> `Altitude r
+  | 07, Rationals [|h;m;s|] -> 
+      `TimeStampUTC (float_of_rational h,
+                     float_of_rational m,
+                     float_of_rational s)
+  | 07, SRationals [|h;m;s|] -> 
+      (* It is illegal in the spec but I see some photos with SRationals *)
+      `TimeStampUTCinSRationals (float_of_srational h,
+                                 float_of_srational m,
+                                 float_of_srational s) 
+
+  | 16, Asciis "T" -> `ImgDirectionTrue
+  | 16, Asciis "M" -> `ImgDirectionMagnetic
+  | 17, Rationals [|r|] -> `ImgDirection r
+  | 18, Asciis s -> `GPSMapDatum s
+  | 29, Asciis s -> `GPSDate (Date.of_string s)
+
+  | _ -> `Unknown (tag, v)
+
+
+let exif_datetime t = match Data.unpack_exif t with
+  | Some entries -> 
+      List.find_map_opt (function
+        | `DateTimeOriginal t -> Some t
+        | _ -> None)
+        (List.map analyze_exif entries)
+  | None -> None
+
+let ifd_0_datetime t = match Data.unpack_ifd_0 t with
+  | Some entries -> 
+      List.find_map_opt (function
+        | `DateTime t -> Some t
+        | _ -> None)
+        (List.map analyze_ifd entries)
+  | None -> None
+
+let datetime t = match exif_datetime t with
+  | (Some _ as res) -> res
+  | None -> ifd_0_datetime t

File src/exifutil.ml

+open Format
+
+module Format = struct
+  include Format
+
+  let array f ppf a = 
+    let len = Array.length a in
+      fprintf ppf "@[[| @[";
+      Array.iteri (fun i v ->
+        f ppf v;
+        if i < len - 1 then fprintf ppf ";@ ")
+        a;
+      fprintf ppf "@] |]@]"
+  
+  let rec list (sep : (unit, formatter, unit) format)  f ppf = function
+    | [] -> ()
+    | [x] -> f ppf x
+    | x::xs -> 
+        fprintf ppf "@[%a@]%t%a" 
+  	f x
+  	(fun ppf -> fprintf ppf sep)
+  	(list sep f) xs
+
+  let opt f ppf = function
+    | None -> fprintf ppf "None"
+    | Some v -> f ppf v
+
+  let option f ppf = function
+    | None -> fprintf ppf "None"
+    | Some v -> fprintf ppf "Some (%a)" f v
+end
+
+module List = struct
+  include List
+
+  let rec find_map_opt f = function
+    | [] -> None
+    | x::xs ->
+        match f x with
+        | Some v -> Some v
+        | None -> find_map_opt f xs
+
+end

File test/OMakefile

 OCAMLPACKS[]=
   graphics
 
-SUB_PACKAGES[]= all graphics freetype
+SUB_PACKAGES[]= all_formats graphics freetype
 
 BuildExample(test, test, $(SUB_PACKAGES))
 
 OCAML_LIBS=
 BuildExample(test2, test2, $(SUB_PACKAGES))
 
+# BuildExample is badly written, so we need reseting OCAML_LIBS
+OCAML_LIBS=
+BuildExample(jpgmark, jpgmark, $(SUB_PACKAGES))
+
+# BuildExample is badly written, so we need reseting OCAML_LIBS
+OCAML_LIBS=
+BuildExample(jpgexif, jpgexif, $(SUB_PACKAGES))
+
 clean:
   rm -f $(filter-proper-targets $(ls R, .))
   rm -f out.image

File test/jpgexif.ml

+(***********************************************************************)
+(*                                                                     *)
+(*                           CamlImages                                *)
+(*                                                                     *)
+(*                           Jun Furuse                                *)
+(*                                                                     *)
+(*  Copyright 1999-2013,                                               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: test.ml,v 1.32.2.1 2010/05/13 13:14:47 furuse Exp $ *)
+
+open Images;;
+open Format;;
+
+open Jpeg;;
+
+(* CR jfuruse: move to Spotlib *)
+let _dump_hex s = 
+  for i = 0 to String.length s - 1 do
+    Printf.printf "%02x " (Char.code s.[i]);
+    if i mod 16 = 15 then Printf.printf "\n";
+  done
+
+let dump path = 
+  Format.eprintf "File: %s@." path;
+  List.iter (fun mrk ->
+    Format.eprintf "  %a@." Jpeg.Marker.format mrk;
+    match mrk with
+    | Jpeg.Marker.App (1, cont) when
+        (try String.sub cont 0 6 = "Exif\000\000" with _ -> false) ->
+        let exif = Exif.Data.from_string cont in
+        Exif.Data.dump exif;
+        Format.eprintf "%a@." Exif.Data.format exif;
+        Exif.Data.dump exif;
+    | _ -> ()
+  ) (Jpeg.read_markers path)
+  
+let images =
+  let images = ref [] in
+  Arg.parse [] (fun x -> images := x :: !images) "test images";
+  List.rev !images
+
+let main () =
+  try List.iter dump images
+  with
+  | Exit -> exit 0
+  | End_of_file -> exit 0
+  | Sys.Break -> exit 2;;
+
+main ();;

File test/jpgmark.ml

+(***********************************************************************)
+(*                                                                     *)
+(*                           CamlImages                                *)
+(*                                                                     *)
+(*                            Jun Furuse                               *)
+(*                                                                     *)
+(*  Copyright 1999-2013,                                               *)
+(*                                                                     *)
+(***********************************************************************)
+
+(* $Id: test.ml,v 1.32.2.1 2010/05/13 13:14:47 furuse Exp $ *)
+
+open Images;;
+open Format;;
+
+open Jpeg;;
+
+let dump path = 
+  Format.eprintf "File: %s@." path;
+  let markers = Jpeg.read_markers path in
+  prerr_endline "markers loaded";
+  List.iter (fun t ->
+    Format.eprintf "  %a@." Jpeg.Marker.format t)
+    markers
+  
+let images =
+  let images = ref [] in
+  Arg.parse [] (fun x -> images := x :: !images) "test images";
+  List.rev !images
+
+let main () =
+  try 
+    for _i = 0 to 10000 do
+      List.iter dump images
+    done
+  with
+  | Exit -> exit 0
+  | End_of_file -> exit 0
+  | Sys.Break -> exit 2;;
+
+main ();;