font-loader-interface.lisp

   1 ;;; Copyright (c) 2006 Zachary Beane, All Rights Reserved
   2 ;;;
   3 ;;; Redistribution and use in source and binary forms, with or without
   4 ;;; modification, are permitted provided that the following conditions
   5 ;;; are met:
   6 ;;;
   7 ;;;   * Redistributions of source code must retain the above copyright
   8 ;;;     notice, this list of conditions and the following disclaimer.
   9 ;;;
  10 ;;;   * Redistributions in binary form must reproduce the above
  11 ;;;     copyright notice, this list of conditions and the following
  12 ;;;     disclaimer in the documentation and/or other materials
  13 ;;;     provided with the distribution.
  14 ;;;
  15 ;;; THIS SOFTWARE IS PROVIDED BY THE AUTHOR 'AS IS' AND ANY EXPRESSED
  16 ;;; OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  17 ;;; WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
  18 ;;; ARE DISCLAIMED.  IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY
  19 ;;; DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL
  20 ;;; DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
  21 ;;; GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
  22 ;;; INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  23 ;;; WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
  24 ;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
  25 ;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  26 ;;;
  27 ;;; Interface functions for creating, initializing, and closing a
  28 ;;; FONT-LOADER object.
  29 ;;;
  30 ;;; $Id: font-loader-interface.lisp,v 1.6 2006/03/23 22:20:35 xach Exp $
  31
  32 (in-package #:zpb-ttf)
  33
  34 (defun arrange-finalization (object stream)
  35   (flet ((quietly-close (&optional object)
  36            (declare (ignore object))
  37            (ignore-errors (close stream))))
  38     #+sbcl
  39     (sb-ext:finalize object #'quietly-close)
  40     #+cmucl
  41     (ext:finalize object #'quietly-close)
  42     #+clisp
  43     (ext:finalize object #'quietly-close)
  44     #+allegro
  45     (excl:schedule-finalization object #'quietly-close)))
  46
  47
  48 (defun check-magic (magic &rest ok)
  49   (cond
  50     ((member magic ok)
  51      t)
  52     ((= magic (tag->number "typ1"))
  53      (error 'unsupported-format
  54             :location "font header"
  55             :description "Old style of PostScript font housed in a sfnt wrapper not supported."
  56             :actual-value magic
  57             :expected-values ok))
  58     ((= magic (tag->number "OTTO"))
  59      (error 'unsupported-format
  60             :location "font header"
  61             :description "OpenType font with PostScript outlines not supported."
  62             :actual-value magic
  63             :expected-values ok))
  64     (t
  65      (error 'bad-magic
  66             :location "font header"
  67             :expected-values ok
  68             :actual-value magic))))
  69 ;;;
  70 ;;; FIXME: move most/all of this stuff into initialize-instance
  71 ;;;
  72
  73 (defun open-font-loader-from-stream (input-stream &key (collection-index 0))
  74   (let ((magic (read-uint32 input-stream))
  75         (font-count))
  76     (check-magic magic #x00010000
  77                  (tag->number "true")
  78                  (tag->number "ttcf"))
  79     (when (= magic (tag->number "ttcf"))
  80       (let ((version (read-uint32 input-stream)))
  81         (check-version "ttc header" version #x00010000 #x00020000)
  82         (setf font-count (read-uint32 input-stream))
  83         (let* ((offset-table (make-array font-count))
  84                (dsig))
  85           (when (> collection-index font-count)
  86             (error 'unsupported-value
  87                    :description "Font index out of range"
  88                    :actual-value collection-index
  89                    :expected-values (list font-count)))
  90           (loop for i below font-count
  91                 do (setf (aref offset-table i) (read-uint32 input-stream)))
  92           (when (= version #x00020000)
  93             (let ((flag (read-uint32 input-stream))
  94                   (length (read-uint32 input-stream))
  95                   (offset (read-uint32 input-stream)))
  96               (list flag length offset)
  97               (when (= #x44534947 flag)
  98                 (setf dsig (list length offset)))))
  99           ;; seek to font offset table
 100           (file-position input-stream (aref offset-table collection-index))
 101           (let ((magic2 (read-uint32 input-stream)))
 102             (check-magic magic2 #x00010000 (tag->number "true"))))))
 103
 104     (let* ((table-count (read-uint16 input-stream))
 105            (font-loader (make-instance 'font-loader
 106                                        :input-stream input-stream
 107                                        :table-count table-count
 108                                        :collection-font-cont font-count
 109                                        :collection-font-index
 110                                        (when font-count
 111                                          collection-index))))
 112       ;; skip the unused stuff:
 113       ;; searchRange, entrySelector, rangeShift
 114       (read-uint16 input-stream)
 115       (read-uint16 input-stream)
 116       (read-uint16 input-stream)
 117       (loop repeat table-count
 118             for tag = (read-uint32 input-stream)
 119             for checksum = (read-uint32 input-stream)
 120             for offset = (read-uint32 input-stream)
 121             for size = (read-uint32 input-stream)
 122             do (setf (gethash tag (tables font-loader))
 123                      (make-instance 'table-info
 124                                     :offset offset
 125                                     :name (number->tag tag)
 126                                     :size size)))
 127       (load-maxp-info font-loader)
 128       (load-head-info font-loader)
 129       (load-kern-info font-loader)
 130       (load-loca-info font-loader)
 131       (load-name-info font-loader)
 132       (load-cmap-info font-loader)
 133       (load-post-info font-loader)
 134       (load-hhea-info font-loader)
 135       (load-hmtx-info font-loader)
 136       (load-vhea-info font-loader)
 137       (load-vmtx-info font-loader)
 138       (setf (glyph-cache font-loader)
 139             (make-array (glyph-count font-loader) :initial-element nil))
 140       font-loader)))
 141
 142 (defun open-font-loader-from-file (thing &key (collection-index 0))
 143   (let ((stream (open thing
 144                       :direction :input
 145                       :element-type '(unsigned-byte 8)
 146                       #+ccl :sharing #+ccl :external)))
 147     (let ((font-loader (open-font-loader-from-stream
 148                         stream :collection-index collection-index)))
 149       (arrange-finalization font-loader stream)
 150       font-loader)))
 151
 152 (defun open-font-loader (thing &key (collection-index 0))
 153   (typecase thing
 154     (font-loader
 155      (cond
 156        ;; We either don't have a collection, or want same font from
 157        ;; collection.
 158        ((or (not (collection-font-index thing))
 159             (= collection-index (collection-font-index thing)))
 160         (unless (open-stream-p (input-stream thing))
 161           (setf (input-stream thing) (open (input-stream thing))))
 162         thing)
 163        (t
 164         (open-font-loader-from-file (input-stream thing)
 165                                     :collection-index collection-index))))
 166     (stream
 167      (if (open-stream-p thing)
 168          (open-font-loader-from-stream thing :collection-index collection-index)
 169          (error "~A is not an open stream" thing)))
 170     (t
 171      (open-font-loader-from-file thing :collection-index collection-index))))
 172
 173 (defun close-font-loader (loader)
 174   (close (input-stream loader)))
 175
 176 (defmacro with-font-loader ((loader file &key (collection-index 0)) &body body)
 177   `(let (,loader)
 178     (unwind-protect
 179          (progn
 180            (setf ,loader (open-font-loader ,file
 181                                            :collection-index ,collection-index))
 182            ,@body)
 183       (when ,loader
 184         (close-font-loader ,loader)))))
 185