REBOL [
  Title: "REBOL::EXIF"
  Description: "REBOL to EXIF interface"
  Date: 2003/12/21
  Version: 1.3
  Id: "$Id: exif-core.r,v 1.3 2003/12/21 17:47:29 narg Exp $"
  Author: "Piotr Gapinski"
  Email: news@rowery.olsztyn.pl
  File: %exif-core.r
  Purpose: "obsluga plikow JPEG/EXIF"
  Copyright: "Olsztynska Strona Rowerowa http://www.rowery.olsztyn.pl"
  License: "GNU Lesser General Public License (Version 2.1)"
  Example: { ;; simple demo program (print out info about Maker and Model)
    either all [
      not none file: request-file 
      good-file?/debug first file ]
    [ dat: exif-tag [#{010f} #{0110}] ;; Maker, Model
      probe dat ]
    [ print "sorry, not an JPEG/EXIF file" ]
  }
  library: [
    level: 'intermediate
    platform: 'all
    type: [module tool]
    domain: [files graphics]
    tested-under: [
      view 1.2.1 on [linux Win2K amiga]
      view 1.2.8 on [linux winxp]
    ] 
   support: none
    license: 'LGPL
  ]
]

exif-ctx: context [
  set 'EXIF-SOI  #{FFD8}
  set 'EXIF-APP0 #{FFE0}
  set 'EXIF-APP1 #{FFE1}
  set 'EXIF-APP2 #{FFE2}
  set 'EXIF-CMT  #{FFFE}
  set 'EXIF-EOI  #{FFD9}

  EXIF-HEADER: #{457869660000}
  TIFF-HEADER-OFFSET: 10

  EXIF-FORMS: [
    #{0001} [1 to-integer]  ;; unsigned byte (1 bajt/komponent)
    #{0002} [1 to-ascii]    ;; ascii napisy koncz sie bajtem zerowym (jest wliczony w wielkośc napisu)
    #{0003} [2 to-integer]  ;; unsigned short (2 bajty/komponent)
    #{0004} [4 to-integer]  ;; unsigned long (4 bajty/komponent)
    #{0005} [8 to-rational] ;; unsigned rational (8 bajow/komponent)
    #{0006} [1 to-integer]  ;; signed byte (1 bajt/komponent)
    #{0007} [1 to-binary]   ;; undefined (1 bajt/komponent)
    #{0008} [2 to-integer]  ;; signed short (2 bajty/komponent)
    #{0009} [4 to-integer]  ;; signed long (4 bajty/komponent)
    #{000A} [8 to-rational] ;; signed rational (8 bajtow/komponent)
    #{000B} [4 to-binary]   ;; signed float (4 bajty/komponent)
    #{000C} [8 to-binary]   ;; double float (8 bajtow/komponent)
  ]

  byte-order: "" ;; MM (Motorola) lub II (Intel)
  dat: none  ;; bufor danych
  debug: false

  range: func [
   "Pobiera fragment danych z bufora (bez weryfikacji zakresu danych); zwraca binary!"
    offset [integer!] "przesuniecie od początku bufora"
    length [integer!] "dlugośc danych bajtach (relatywna do offsetu)"
   /all "dlugośc danych liczona od pocztku bufora"
   /custom "bufor danych" buffer [series!] "opcjonalny bufor z danymi"
   /local d] [

    d: any [buffer dat] ;; albo bufor przekazany jako paramentr albo bufor 'dat'
    copy/part (skip d offset) (either all [length - offset] [length])
  ]

  get-content: func [
   "Pobiera size danych znajdujących sie location bajtow za naglowkiem bufora; zwraca binary!"
    location [integer!] "przesuniecie od początku bufora"
    size [integer!] "dlugośc danych bajtach (relatywna do offsetu)"] [

    range (TIFF-HEADER-OFFSET + location) size
  ]

  intel?: func [
   "Konwersja zapisu danych binarnych Intel-Motorola (zmiana kolejności bajtow)."
    bin [binary!] "dane binarne" ] [
    either (byte-order = "II") [head reverse bin] [bin]
  ]

  read-traverse: func [
   "Poszukuje tag w pliki JPEG; zwraca binary! (zawartośc chunk) lub none!"
    file-name [file! string!] "nazwa pliku"
    tag [binary!] "szukany chunk-id"
   /position "zwraca offset pozycji chunk od pocztku pliku"
   /local chunk-id chunk-size offset buffer] [

    file: to-file file-name
    if error? try [
      buffer: read/binary/direct/part file 2
      if not equal? EXIF-SOI (range/custom 0 2 buffer) [return none] ;; jezeli naglowek pliku <> EXIF-SOI to nie jest to plik JPEG
      ;; buffer: skip dat 2 ;; pomin SOI

      offset: 2
      forever [
        buffer: read/binary/direct/part file (offset + 4) ;; wczytaj id bloku danch i ich wielkośc
        chunk-id: range/custom offset 2 buffer
        mask: to-integer #{FF00}
        if (((to-integer chunk-id) and mask) <> mask) [return none]

        chunk-size: to-integer range/custom (offset + 2) 2 buffer

        if debug [print ["znaleziono chunk" chunk-id "offset" offset "wielkośc" (chunk-size + 2) "bajtow"]]

        if (chunk-id = tag) [
          buffer: skip (read/binary/direct/part file (offset + chunk-size + 2)) offset
          return either position [offset] [buffer]
        ]
        offset: offset + chunk-size + 2
      ]
    ] [return none]
  ]

  set 'exif-file? func [
   "Bada czy plik jest w formacie JPEG i zawiera dane EXIF-APP1; zwraca logic!"
    file-name [file! string!] "nazwa pliku"
   /debug "dodatkowe informacje o dzialaniu programu"
   /local size] [

    self/debug: any [(not none? debug) false]
    not none? all [
      not none? dat: read-traverse file-name EXIF-APP1
      equal? EXIF-APP1 range 0 2 ;; bajty 02:04 = FFE1
      not zero? size: to-integer range 2 2 ;; wielkośc chunk APP1
      not empty? byte-order: to-string range 10 2
    ]
  ]
  set 'good-file? :exif-file? ;; synonim

  set 'exif-tag func [
   "Przeszukuje katalogi struktury EXIF; zwraca block!, binary! lub none!"
    tag [binary! block!] "poszukiwane znaczniki"
   /local ifd-first ifd-next search-ifds ifds rcs tags offset] [

    if none? dat [return none]
    ;; offsety s licznone wzgledem pocztku naglowka APP1 #{FFE1}
    ifd-first: does [TIFF-HEADER-OFFSET + to-integer (intel? range 14 4)] ;; IFD0
    ifd-next: func [
     "Zwraca integer! offset do nastepnego IFD lub none!"
      offset "aktualna pozycja katalogu"
     /local elements next] [

      ;; kazdy katalog zawiera nastepujce dane
      ;; 00-02 liczba elementow (tagow) w katalogu
      ;; ..... 12 bajtow na kazdy element w katalogu
      ;; ..... 4-ro bajtowy wskaznik do nastepnego IFD lub 0

      elements: to-integer (intel? range offset 2)
      next: to-integer (intel? range (offset + 2 + (elements * 12)) 4)
      either equal? 0 next [none] [TIFF-HEADER-OFFSET + next]
    ]
    search-ifds: func [
     "Szuka znacznika tag we wszystkich katalogach APP1."
      ifds [block!] "block! offsetow do katalogow APP1"
      tag [binary!] "szukany znacznik EXIF"
     /local offset rc] [

      foreach offset ifds [if not none? (rc: ifd-content offset tag) [break]]
      return rc
    ]

    ifds: copy [] tags: copy [] rcs: copy []

    ;; tworznie tablicy z pozycjami wszystkich katalogow EXIF v2.1
    append ifds offset: ifd-first ;; IFD0
    while [not none? (offset: ifd-next offset)] [append ifds offset] ;; IFD1,...

    ;; foreach tag [#{8769} #{A005} #{8825}] [ ;; SUBIFD0 Interoperability GPSIFD
    foreach tag [#{8769} #{A005}] [ ;; SUBIFD0 Interoperability
      offset: search-ifds ifds tag
      if not none? offset [append ifds (TIFF-HEADER-OFFSET + (to-integer offset))]
    ]
    ifds: sort ifds ;; znaczniki najcześciej uzywane s przewaznie w pocztkowych katalogach

    if debug [print ["znalezione katalogi" mold ifds CRLF "rozpoczynam poszukiwania" CRLF]]

    ;; traktuj przekazany parametr (tag) jako block! danych
    ;; zapisuj wartośc kazdego paramtru lub none! gdy nie znaleziony
    ;; pojedyncze wartości s zwracane bez bloku (brana jest pierwsza wartośc z listy)

    either block? tag [tags: tag][append tags tag]
    foreach tag tags [append rcs (search-ifds ifds tag)]
    either (block? tag) [rcs] [first rcs]
  ]
  set 'exif-ifd :exif-tag

  ifd-content: func [
   "Wyszukuje określony parametr w katalogu EXIF; zwraca jego wartośc lub none!"
    offset [integer!] "lokalizacja (offset) katalogu"
    tag [binary!] "poszukiwany znacznik"
   /local items tag-format tag-length tag-value tag-components] [

    items: to-integer intel? range offset 2 ;; liczba parametrow w biezcym katalogu EXIF

    if debug [print ["szkukam" tag "w katalogu" offset "(" items "elementy/ow )"]]

    offset: offset + 2 ;; pomin 2 bajty z liczb elementow

    loop items [
      ;; na kazdy element w katalogu przypada 12 bajtow
      ;; 00-02 znacznik
      ;; 02-04 format danych (zobacz EXIF-FORM)
      ;; 04-08 liczb cześci z ktorych skladaj sie dane (liczba cześci nie oznacza liczby bajtow!)
      ;; 08-12 dane znacznika lub offset do danych gdy ich dlugośc przekracza 4 bajty

      if debug [print ["-> znaleziono znacznik" (intel? range offset 2)]]
      if equal? tag (intel? range offset 2) [

        ;; znaleziono wlaściwy tag - pobierz jego wartośc
        tag-format: intel? range (offset + 2) 2
        tag-components: to-integer intel? range (offset + 4) 4
        tag-length: tag-components * EXIF-FORMS/:tag-format/1 ;; liczba bajtow przypadajca na dane jednego znacznika

        tag-value: intel? range offset + 8 4
        if (tag-length > 4) [tag-value: range (TIFF-HEADER-OFFSET + to-integer tag-value) tag-length]

        if debug [print ["-> format" tag-format tag-components "komponent/ow w buforze" tag-value "(" tag-length "bajt/y )" CRLF]]

        ;; zamien na rebol datatype
        return to-rebol tag-value tag-format tag-length
      ]
      offset: offset + 12 ;; do nastepnego znacznika w biezcym katalogu
    ]

    if debug [print ["-> znacznika" tag "nie znaleziono!" CRLF]]
    return none
  ]

  to-rebol: func [
   "Konwersja danych binarnych na Rebol datatype."
    bin [binary!] "dane binarne"
    format [binary!] "format danych"
    length [integer!] "bajtow danych (binarnych)"] [

    to-rational: func [bin [binary!] /local a b] [
      a: intel? copy/part bin 4
      b: intel? copy/part skip bin 4 4
      to-string rejoin [(to-integer a) "/" (to-integer b)]
    ]
    to-ascii: func  [bin [binary!]] [trim to-string bin]

    ;; zwracaj tylko tyle bajtow ile jest danych
    ;; zmienna bin ma 4 bajty lub wiecej a np. dla typu "unsigned short" potrzebujemy tylko 2 bajtow
    ;; proteza jest potrzebna dla typow "short", "byte" czy "ascii", ktore mog zawierac pojedyncze bajty

    return do EXIF-FORMS/:format/2 copy/part skip bin ((length? bin) - length) length
  ]
]