  Copyright ( c ) 2006   , All Rights Reserved
;;;
;;; Redistribution and use in source and binary forms, with or without
;;; modification, are permitted provided that the following conditions
;;; are met:
;;;
;;;   * Redistributions of source code must retain the above copyright
;;;     notice, this list of conditions and the following disclaimer.
;;;
;;;   * Redistributions in binary form must reproduce the above
;;;     copyright notice, this list of conditions and the following
;;;     disclaimer in the documentation and/or other materials
;;;     provided with the distribution.
;;;
;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  DIRECT , INDIRECT , INCIDENTAL , SPECIAL , EXEMPLARY , OR CONSEQUENTIAL
;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  INTERRUPTION ) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY ,
;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
  Interface functions for creating , initializing , and closing a
;;; FONT-LOADER object.
;;;
  $ I d : font - loader - interface.lisp , v 1.6 2006/03/23 22:20:35 xach Exp $

(in-package #:zpb-ttf)

(defun arrange-finalization (object stream)
  (flet ((quietly-close (&optional object)
           (declare (ignore object))
           (ignore-errors (close stream))))
    #+sbcl
    (sb-ext:finalize object #'quietly-close)
    #+cmucl
    (ext:finalize object #'quietly-close)
    #+clisp
    (ext:finalize object #'quietly-close)
    #+allegro
    (excl:schedule-finalization object #'quietly-close)))
    

(defun check-magic (magic &rest ok)
  (cond
    ((member magic ok)
     t)
    ((= magic (tag->number "typ1"))
     (error 'unsupported-format
            :location "font header"
            :description "Old style of PostScript font housed in a sfnt wrapper not supported."
            :actual-value magic
            :expected-values ok))
    ((= magic (tag->number "OTTO"))
     (error 'unsupported-format
            :location "font header"
            :description "OpenType font with PostScript outlines not supported."
            :actual-value magic
            :expected-values ok))
    (t
     (error 'bad-magic
            :location "font header"
            :expected-values ok
            :actual-value magic))))
;;;
;;; FIXME: move most/all of this stuff into initialize-instance
;;;

(defun open-font-loader-from-stream (input-stream &key (collection-index 0))
  (let ((magic (read-uint32 input-stream))
        (font-count))
    (check-magic magic #x00010000
                 (tag->number "true")
                 (tag->number "ttcf"))
    (when (= magic (tag->number "ttcf"))
      (let ((version (read-uint32 input-stream)))
        (check-version "ttc header" version #x00010000 #x00020000)
        (setf font-count (read-uint32 input-stream))
        (let* ((offset-table (make-array font-count))
               (dsig))
          (when (> collection-index font-count)
            (error 'unsupported-value
                   :description "Font index out of range"
                   :actual-value collection-index
                   :expected-values (list font-count)))
          (loop for i below font-count
                do (setf (aref offset-table i) (read-uint32 input-stream)))
          (when (= version #x00020000)
            (let ((flag (read-uint32 input-stream))
                  (length (read-uint32 input-stream))
                  (offset (read-uint32 input-stream)))
              (list flag length offset)
              (when (= #x44534947 flag)
                (setf dsig (list length offset)))))
          ;; seek to font offset table
          (file-position input-stream (aref offset-table collection-index))
          (let ((magic2 (read-uint32 input-stream)))
            (check-magic magic2 #x00010000 (tag->number "true"))))))

    (let* ((table-count (read-uint16 input-stream))
           (font-loader (make-instance 'font-loader
                                       :input-stream input-stream
                                       :table-count table-count
                                       :collection-font-cont font-count
                                       :collection-font-index
                                       (when font-count
                                         collection-index))))
      ;; skip the unused stuff:
      ;; searchRange, entrySelector, rangeShift
      (read-uint16 input-stream)
      (read-uint16 input-stream)
      (read-uint16 input-stream)
      (loop repeat table-count
            for tag = (read-uint32 input-stream)
            for checksum = (read-uint32 input-stream)
            for offset = (read-uint32 input-stream)
            for size = (read-uint32 input-stream)
            do (setf (gethash tag (tables font-loader))
                     (make-instance 'table-info
                                    :offset offset
                                    :name (number->tag tag)
                                    :size size)))
      (load-maxp-info font-loader)
      (load-head-info font-loader)
      (load-kern-info font-loader)
      (load-loca-info font-loader)
      (load-name-info font-loader)
      (load-cmap-info font-loader)
      (load-post-info font-loader)
      (load-hhea-info font-loader)
      (load-hmtx-info font-loader)
      (setf (glyph-cache font-loader)
            (make-array (glyph-count font-loader) :initial-element nil))
      font-loader)))

(defun open-font-loader-from-file (thing &key (collection-index 0))
  (let ((stream (open thing
                      :direction :input
                      :element-type '(unsigned-byte 8)
                      #+ccl :sharing #+ccl :external)))
    (let ((font-loader (open-font-loader-from-stream
                        stream :collection-index collection-index)))
      (arrange-finalization font-loader stream)
      font-loader)))

(defun open-font-loader (thing &key (collection-index 0))
  (typecase thing
    (font-loader
     (cond
       ;; We either don't have a collection, or want same font from
       ;; collection.
       ((or (not (collection-font-index thing))
            (= collection-index (collection-font-index thing)))
        (unless (open-stream-p (input-stream thing))
          (setf (input-stream thing) (open (input-stream thing))))
        thing)
       (t
        (open-font-loader-from-file (input-stream thing)
                                    :collection-index collection-index))))
    (stream
     (if (open-stream-p thing)
         (open-font-loader-from-stream thing :collection-index collection-index)
         (error "~A is not an open stream" thing)))
    (t
     (open-font-loader-from-file thing :collection-index collection-index))))

(defun close-font-loader (loader)
  (close (input-stream loader)))

(defmacro with-font-loader ((loader file &key (collection-index 0)) &body body)
  `(let (,loader)
    (unwind-protect
         (progn
           (setf ,loader (open-font-loader ,file
                                           :collection-index ,collection-index))
           ,@body)
      (when ,loader
        (close-font-loader ,loader)))))



 Redistribution and use in source and binary forms, with or without
 modification, are permitted provided that the following conditions
 are met:

   * Redistributions of source code must retain the above copyright
     notice, this list of conditions and the following disclaimer.

   * Redistributions in binary form must reproduce the above
     copyright notice, this list of conditions and the following
     disclaimer in the documentation and/or other materials
     provided with the distribution.

 THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
 OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
 WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
 ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
 DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
 GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
 WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
 NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
 SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

 FONT-LOADER object.


 FIXME: move most/all of this stuff into initialize-instance

 seek to font offset table
 skip the unused stuff:
 searchRange, entrySelector, rangeShift
 We either don't have a collection, or want same font from
 collection.
  Copyright ( c ) 2006   , All Rights Reserved
  DIRECT , INDIRECT , INCIDENTAL , SPECIAL , EXEMPLARY , OR CONSEQUENTIAL
  INTERRUPTION ) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY ,
  Interface functions for creating , initializing , and closing a
  $ I d : font - loader - interface.lisp , v 1.6 2006/03/23 22:20:35 xach Exp $

(in-package #:zpb-ttf)

(defun arrange-finalization (object stream)
  (flet ((quietly-close (&optional object)
           (declare (ignore object))
           (ignore-errors (close stream))))
    #+sbcl
    (sb-ext:finalize object #'quietly-close)
    #+cmucl
    (ext:finalize object #'quietly-close)
    #+clisp
    (ext:finalize object #'quietly-close)
    #+allegro
    (excl:schedule-finalization object #'quietly-close)))
    

(defun check-magic (magic &rest ok)
  (cond
    ((member magic ok)
     t)
    ((= magic (tag->number "typ1"))
     (error 'unsupported-format
            :location "font header"
            :description "Old style of PostScript font housed in a sfnt wrapper not supported."
            :actual-value magic
            :expected-values ok))
    ((= magic (tag->number "OTTO"))
     (error 'unsupported-format
            :location "font header"
            :description "OpenType font with PostScript outlines not supported."
            :actual-value magic
            :expected-values ok))
    (t
     (error 'bad-magic
            :location "font header"
            :expected-values ok
            :actual-value magic))))

(defun open-font-loader-from-stream (input-stream &key (collection-index 0))
  (let ((magic (read-uint32 input-stream))
        (font-count))
    (check-magic magic #x00010000
                 (tag->number "true")
                 (tag->number "ttcf"))
    (when (= magic (tag->number "ttcf"))
      (let ((version (read-uint32 input-stream)))
        (check-version "ttc header" version #x00010000 #x00020000)
        (setf font-count (read-uint32 input-stream))
        (let* ((offset-table (make-array font-count))
               (dsig))
          (when (> collection-index font-count)
            (error 'unsupported-value
                   :description "Font index out of range"
                   :actual-value collection-index
                   :expected-values (list font-count)))
          (loop for i below font-count
                do (setf (aref offset-table i) (read-uint32 input-stream)))
          (when (= version #x00020000)
            (let ((flag (read-uint32 input-stream))
                  (length (read-uint32 input-stream))
                  (offset (read-uint32 input-stream)))
              (list flag length offset)
              (when (= #x44534947 flag)
                (setf dsig (list length offset)))))
          (file-position input-stream (aref offset-table collection-index))
          (let ((magic2 (read-uint32 input-stream)))
            (check-magic magic2 #x00010000 (tag->number "true"))))))

    (let* ((table-count (read-uint16 input-stream))
           (font-loader (make-instance 'font-loader
                                       :input-stream input-stream
                                       :table-count table-count
                                       :collection-font-cont font-count
                                       :collection-font-index
                                       (when font-count
                                         collection-index))))
      (read-uint16 input-stream)
      (read-uint16 input-stream)
      (read-uint16 input-stream)
      (loop repeat table-count
            for tag = (read-uint32 input-stream)
            for checksum = (read-uint32 input-stream)
            for offset = (read-uint32 input-stream)
            for size = (read-uint32 input-stream)
            do (setf (gethash tag (tables font-loader))
                     (make-instance 'table-info
                                    :offset offset
                                    :name (number->tag tag)
                                    :size size)))
      (load-maxp-info font-loader)
      (load-head-info font-loader)
      (load-kern-info font-loader)
      (load-loca-info font-loader)
      (load-name-info font-loader)
      (load-cmap-info font-loader)
      (load-post-info font-loader)
      (load-hhea-info font-loader)
      (load-hmtx-info font-loader)
      (setf (glyph-cache font-loader)
            (make-array (glyph-count font-loader) :initial-element nil))
      font-loader)))

(defun open-font-loader-from-file (thing &key (collection-index 0))
  (let ((stream (open thing
                      :direction :input
                      :element-type '(unsigned-byte 8)
                      #+ccl :sharing #+ccl :external)))
    (let ((font-loader (open-font-loader-from-stream
                        stream :collection-index collection-index)))
      (arrange-finalization font-loader stream)
      font-loader)))

(defun open-font-loader (thing &key (collection-index 0))
  (typecase thing
    (font-loader
     (cond
       ((or (not (collection-font-index thing))
            (= collection-index (collection-font-index thing)))
        (unless (open-stream-p (input-stream thing))
          (setf (input-stream thing) (open (input-stream thing))))
        thing)
       (t
        (open-font-loader-from-file (input-stream thing)
                                    :collection-index collection-index))))
    (stream
     (if (open-stream-p thing)
         (open-font-loader-from-stream thing :collection-index collection-index)
         (error "~A is not an open stream" thing)))
    (t
     (open-font-loader-from-file thing :collection-index collection-index))))

(defun close-font-loader (loader)
  (close (input-stream loader)))

(defmacro with-font-loader ((loader file &key (collection-index 0)) &body body)
  `(let (,loader)
    (unwind-protect
         (progn
           (setf ,loader (open-font-loader ,file
                                           :collection-index ,collection-index))
           ,@body)
      (when ,loader
        (close-font-loader ,loader)))))

