name.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 ;;; Loading data from the TrueType "name" table.
  28 ;;;
  29 ;;;   http://www.microsoft.com/OpenType/OTSpec/name.htm
  30 ;;;   http://developer.apple.com/fonts/TTRefMan/RM06/Chap6name.html
  31 ;;;
  32 ;;; $Id: name.lisp,v 1.8 2006/02/18 23:13:43 xach Exp $
  33
  34 (in-package #:zpb-ttf)
  35
  36 (defvar *name-identifiers*
  37   #(:copyright-notice
  38     :font-family
  39     :font-subfamily
  40     :unique-subfamily
  41     :full-name
  42     :name-table-version
  43     :postscript-name
  44     :trademark-notice
  45     :manufacturer-name
  46     :designer
  47     :description
  48     :vendor-url
  49     :designer-url
  50     :license-description
  51     :licence-info-url
  52     :reserved
  53     :preferred-family
  54     :preferred-subfamily
  55     :compatible-full
  56     :sample-text))
  57
  58 (defvar *platform-identifiers*
  59   #(:unicode
  60     :macintosh
  61     :iso
  62     :microsoft
  63     :custom))
  64
  65 (defvar *unicode-encoding-ids*
  66   #(:unicode-1.0
  67     :unicode-1.1
  68     :iso-10646\:1993
  69     :unicode>=2.0-bmp-only
  70     :unicode>=2.0-full-repertoire))
  71
  72 (defvar *microsoft-encoding-ids*
  73   #(:symbol
  74     :unicode
  75     :shiftjis
  76     :prc
  77     :big5
  78     :wansung
  79     :johab
  80     :reserved
  81     :reserved
  82     :reserved
  83     :ucs-4))
  84
  85 (defvar *macintosh-encoding-ids*
  86   #(:roman
  87     :japanese
  88     :chinese-traditional
  89     :korean
  90     :arabic
  91     :hebrew
  92     :greek
  93     :russian
  94     :RSymbol
  95     :devanagari
  96     :gurmukhi
  97     :gujarati
  98     :oriya
  99     :bengali
 100     :tamil
 101     :telugu
 102     :kennada
 103     :malayam
 104     :sinhalese
 105     :burmese
 106     :khmer
 107     :thai
 108     :laotian
 109     :georgian
 110     :armenian
 111     :chinese-simplified
 112     :tibetan
 113     :mongolian
 114     :geez
 115     :slavic
 116     :vietnamese
 117     :sindhi
 118     :uninterpreted))
 119
 120 (defparameter *encoding-tables*
 121   (vector *unicode-encoding-ids*
 122           *macintosh-encoding-ids*
 123           nil
 124           *microsoft-encoding-ids*
 125           nil))
 126
 127 (defun encoding-id-name (platform-id encoding-id)
 128   (aref (aref *encoding-tables* platform-id) encoding-id))
 129
 130 (defun platform-id-name (platform-id)
 131   (aref *platform-identifiers* platform-id))
 132
 133 (defparameter *macroman-translation-table*
 134   #(#x00 #x00
 135     #x01 #x01
 136     #x02 #x02
 137     #x03 #x03
 138     #x04 #x04
 139     #x05 #x05
 140     #x06 #x06
 141     #x07 #x07
 142     #x08 #x08
 143     #x09 #x09
 144     #x0A #x0A
 145     #x0B #x0B
 146     #x0C #x0C
 147     #x0D #x0D
 148     #x0E #x0E
 149     #x0F #x0F
 150     #x10 #x10
 151     #x11 #x11
 152     #x12 #x12
 153     #x13 #x13
 154     #x14 #x14
 155     #x15 #x15
 156     #x16 #x16
 157     #x17 #x17
 158     #x18 #x18
 159     #x19 #x19
 160     #x1A #x1A
 161     #x1B #x1B
 162     #x1C #x1C
 163     #x1D #x1D
 164     #x1E #x1E
 165     #x1F #x1F
 166     #x20 #x20
 167     #x21 #x21
 168     #x22 #x22
 169     #x23 #x23
 170     #x24 #x24
 171     #x25 #x25
 172     #x26 #x26
 173     #x27 #x27
 174     #x28 #x28
 175     #x29 #x29
 176     #x2A #x2A
 177     #x2B #x2B
 178     #x2C #x2C
 179     #x2D #x2D
 180     #x2E #x2E
 181     #x2F #x2F
 182     #x30 #x30
 183     #x31 #x31
 184     #x32 #x32
 185     #x33 #x33
 186     #x34 #x34
 187     #x35 #x35
 188     #x36 #x36
 189     #x37 #x37
 190     #x38 #x38
 191     #x39 #x39
 192     #x3A #x3A
 193     #x3B #x3B
 194     #x3C #x3C
 195     #x3D #x3D
 196     #x3E #x3E
 197     #x3F #x3F
 198     #x40 #x40
 199     #x41 #x41
 200     #x42 #x42
 201     #x43 #x43
 202     #x44 #x44
 203     #x45 #x45
 204     #x46 #x46
 205     #x47 #x47
 206     #x48 #x48
 207     #x49 #x49
 208     #x4A #x4A
 209     #x4B #x4B
 210     #x4C #x4C
 211     #x4D #x4D
 212     #x4E #x4E
 213     #x4F #x4F
 214     #x50 #x50
 215     #x51 #x51
 216     #x52 #x52
 217     #x53 #x53
 218     #x54 #x54
 219     #x55 #x55
 220     #x56 #x56
 221     #x57 #x57
 222     #x58 #x58
 223     #x59 #x59
 224     #x5A #x5A
 225     #x5B #x5B
 226     #x5C #x5C
 227     #x5D #x5D
 228     #x5E #x5E
 229     #x5F #x5F
 230     #x60 #x60
 231     #x61 #x61
 232     #x62 #x62
 233     #x63 #x63
 234     #x64 #x64
 235     #x65 #x65
 236     #x66 #x66
 237     #x67 #x67
 238     #x68 #x68
 239     #x69 #x69
 240     #x6A #x6A
 241     #x6B #x6B
 242     #x6C #x6C
 243     #x6D #x6D
 244     #x6E #x6E
 245     #x6F #x6F
 246     #x70 #x70
 247     #x71 #x71
 248     #x72 #x72
 249     #x73 #x73
 250     #x74 #x74
 251     #x75 #x75
 252     #x76 #x76
 253     #x77 #x77
 254     #x78 #x78
 255     #x79 #x79
 256     #x7A #x7A
 257     #x7B #x7B
 258     #x7C #x7C
 259     #x7D #x7D
 260     #x7E #x7E
 261     #x7F #x7F
 262     #x80 #x00C4
 263     #x81 #x00C5
 264     #x82 #x00C7
 265     #x83 #x00C9
 266     #x84 #x00D1
 267     #x85 #x00D6
 268     #x86 #x00DC
 269     #x87 #x00E1
 270     #x88 #x00E0
 271     #x89 #x00E2
 272     #x8A #x00E4
 273     #x8B #x00E3
 274     #x8C #x00E5
 275     #x8D #x00E7
 276     #x8E #x00E9
 277     #x8F #x00E8
 278     #x90 #x00EA
 279     #x91 #x00EB
 280     #x92 #x00ED
 281     #x93 #x00EC
 282     #x94 #x00EE
 283     #x95 #x00EF
 284     #x96 #x00F1
 285     #x97 #x00F3
 286     #x98 #x00F2
 287     #x99 #x00F4
 288     #x9A #x00F6
 289     #x9B #x00F5
 290     #x9C #x00FA
 291     #x9D #x00F9
 292     #x9E #x00FB
 293     #x9F #x00FC
 294     #xA0 #x2020
 295     #xA1 #x00B0
 296     #xA2 #x00A2
 297     #xA3 #x00A3
 298     #xA4 #x00A7
 299     #xA5 #x2022
 300     #xA6 #x00B6
 301     #xA7 #x00DF
 302     #xA8 #x00AE
 303     #xA9 #x00A9
 304     #xAA #x2122
 305     #xAB #x00B4
 306     #xAC #x00A8
 307     #xAD #x2260
 308     #xAE #x00C6
 309     #xAF #x00D8
 310     #xB0 #x221E
 311     #xB1 #x00B1
 312     #xB2 #x2264
 313     #xB3 #x2265
 314     #xB4 #x00A5
 315     #xB5 #x00B5
 316     #xB6 #x2202
 317     #xB7 #x2211
 318     #xB8 #x220F
 319     #xB9 #x03C0
 320     #xBA #x222B
 321     #xBB #x00AA
 322     #xBC #x00BA
 323     #xBD #x03A9
 324     #xBE #x00E6
 325     #xBF #x00F8
 326     #xC0 #x00BF
 327     #xC1 #x00A1
 328     #xC2 #x00AC
 329     #xC3 #x221A
 330     #xC4 #x0192
 331     #xC5 #x2248
 332     #xC6 #x2206
 333     #xC7 #x00AB
 334     #xC8 #x00BB
 335     #xC9 #x2026
 336     #xCA #x00A0
 337     #xCB #x00C0
 338     #xCC #x00C3
 339     #xCD #x00D5
 340     #xCE #x0152
 341     #xCF #x0153
 342     #xD0 #x2103
 343     #xD1 #x2014
 344     #xD2 #x201C
 345     #xD3 #x201D
 346     #xD4 #x2018
 347     #xD5 #x2019
 348     #xD6 #x00F7
 349     #xD7 #x25CA
 350     #xD8 #x00FF
 351     #xD9 #x0178
 352     #xDA #x2044
 353     #xDB #x20AC
 354     #xDC #x2039
 355     #xDD #x203A
 356     #xDE #xFB01
 357     #xDF #xFB02
 358     #xE0 #x2021
 359     #xE1 #x00B7
 360     #xE2 #x201A
 361     #xE3 #x201E
 362     #xE4 #x2030
 363     #xE5 #x00C2
 364     #xE6 #x00CA
 365     #xE7 #x00C1
 366     #xE8 #x00CB
 367     #xE9 #x00C8
 368     #xEA #x00CD
 369     #xEB #x00CE
 370     #xEC #x00CF
 371     #xED #x00CC
 372     #xEE #x00D3
 373     #xEF #x00D4
 374     #xF0 #xF8FF
 375     #xF1 #x00D2
 376     #xF2 #x00DA
 377     #xF3 #x00DB
 378     #xF4 #x00D9
 379     #xF5 #x0131
 380     #xF6 #x02C6
 381     #xF7 #x02DC
 382     #xF8 #x00AF
 383     #xF9 #x02D8
 384     #xFA #x02D9
 385     #xFB #x02DA
 386     #xFC #x00B8
 387     #xFD #x02DD
 388     #xFE #x02DB
 389     #xFF #x02C7))
 390
 391 (defconstant +unicode-platform-id+   0)
 392 (defconstant +macintosh-platform-id+ 1)
 393 (defconstant +iso-platform-id+       2)
 394 (defconstant +microsoft-platform-id+ 3)
 395 (defconstant +custom-platform-id+    4)
 396
 397 (defconstant +unicode-2.0-encoding-id+           3)
 398 (defconstant +microsoft-unicode-bmp-encoding-id+ 1)
 399 (defconstant +microsoft-symbol-encoding-id+      0)
 400 (defconstant +macintosh-roman-encoding-id+       1)
 401
 402 ;; Full list of microsoft language IDs is here:
 403 ;;  http://www.microsoft.com/globaldev/reference/lcid-all.mspx
 404
 405 (defconstant +microsoft-us-english-language-id+ #x0409)
 406 (defconstant +macintosh-english-language-id+    1)
 407 (defconstant +unicode-language-id+              0)
 408
 409
 410 (defclass name-entry ()
 411   ((font-loader
 412     :initarg :font-loader
 413     :accessor font-loader)
 414    (platform-id
 415     :initarg :platform-id
 416     :accessor platform-id)
 417    (encoding-id
 418     :initarg :encoding-id
 419     :accessor encoding-id)
 420    (language-id
 421     :initarg :language-id
 422     :accessor language-id)
 423    (name-id
 424     :initarg :name-id
 425     :accessor name-id)
 426    (offset
 427     :initarg :offset
 428     :accessor offset
 429     :documentation "The octet offset within the TrueType file stream
 430 of the entry's data. *Not* the same as the offset in the NameRecord
 431 structure, which is relative to the start of the string data for the
 432 table.")
 433    (entry-length
 434     :initarg :entry-length
 435     :accessor entry-length)
 436    (value
 437     :reader %value
 438     :writer (setf value))
 439    (octets
 440     :reader %octets
 441     :writer (setf octets))))
 442
 443 (defmethod print-object ((name-entry name-entry) stream)
 444   (print-unreadable-object (name-entry stream :type t)
 445     (format stream "~A (~A/~A/~D)"
 446             (aref *name-identifiers* (name-id name-entry))
 447             (platform-id-name (platform-id name-entry))
 448             (encoding-id-name (platform-id name-entry)
 449                               (encoding-id name-entry))
 450             (language-id name-entry))))
 451
 452 (defun unicode-octets-to-string (octets)
 453   (let ((string (make-string (/ (length octets) 2))))
 454     (flet ((ref16 (i)
 455              (+ (ash (aref octets i) 16)
 456                 (aref octets (1+ i)))))
 457       (loop for i from 0 below (length octets) by 2
 458             for j from 0
 459             do (setf (char string j) (code-char (ref16 i))))
 460       string)))
 461
 462 (defun macintosh-octets-to-string (octets)
 463   (flet ((macroman->unicode (point)
 464            (code-char (aref *macroman-translation-table* (1+ (ash point 1))))))
 465     (let ((string (make-string (length octets))))
 466       (dotimes (i (length octets) string)
 467         (setf (schar string i) (macroman->unicode (aref octets i)))))))
 468
 469 (defgeneric initialize-name-entry (name-entry)
 470   (:method (name-entry)
 471     (let ((stream (input-stream (font-loader name-entry)))
 472           (octets (make-array (entry-length name-entry)
 473                               :element-type '(unsigned-byte 8)))
 474           (value nil)
 475           (platform-id (platform-id name-entry)))
 476       (file-position stream (offset name-entry))
 477       (read-sequence octets stream)
 478       (cond ((or (= platform-id +unicode-platform-id+)
 479                  (= platform-id +microsoft-platform-id+))
 480              (setf value (unicode-octets-to-string octets)))
 481             ((= platform-id +macintosh-platform-id+)
 482              (setf value (macintosh-octets-to-string octets)))
 483             (t
 484              (error 'unsupported-value
 485                     :location "\"name\" table platform ID"
 486                     :actual-value platform-id
 487                     :expected-values (list +unicode-platform-id+
 488                                            +microsoft-platform-id+
 489                                            +macintosh-platform-id+))))
 490       (setf (value name-entry) value
 491             (octets name-entry) octets))))
 492
 493 (defgeneric value (name-entry)
 494   (:method (name-entry)
 495     (unless (slot-boundp name-entry 'value)
 496       (initialize-name-entry name-entry))
 497     (%value name-entry)))
 498
 499 (defgeneric octets (name-entry)
 500   (:method (name-entry)
 501     (unless (slot-boundp name-entry 'octets)
 502       (initialize-name-entry name-entry))
 503     (%octets name-entry)))
 504
 505 (defun load-name-info (loader)
 506   (seek-to-table "name" loader)
 507   (let* ((stream (input-stream loader))
 508          (table-offset (file-position stream))
 509          (format (read-uint16 stream)))
 510     (unless (= format 0)
 511       (error 'unsupported-format
 512              :location "\"name\" table"
 513              :actual-value format
 514              :expected-values (list 0)))
 515     (let* ((count (read-uint16 stream))
 516            (values-offset (read-uint16 stream))
 517            (entries (make-array count)))
 518       (setf (name-entries loader) entries)
 519       (dotimes (i count)
 520         (let ((platform-id (read-uint16 stream))
 521               (encoding-id (read-uint16 stream))
 522               (language-id (read-uint16 stream))
 523               (name-id (read-uint16 stream))
 524               (length (read-uint16 stream))
 525               (offset (read-uint16 stream)))
 526           (setf (aref entries i)
 527                 (make-instance 'name-entry
 528                                :font-loader loader
 529                                :platform-id platform-id
 530                                :encoding-id encoding-id
 531                                :language-id language-id
 532                                :name-id name-id
 533                                :entry-length length
 534                                :offset (+ table-offset values-offset offset))))))))
 535
 536 ;;;
 537 ;;; Fetching info out of the name-entry vector
 538 ;;;
 539
 540 (defun name-identifier-id (symbol)
 541   (let ((id (position symbol *name-identifiers*)))
 542     (if id
 543         id
 544         (error "Unknown NAME identifier: ~S" symbol))))
 545
 546
 547 (defmethod find-name-entry (platform-id encoding-id language-id name-id
 548                             (font-loader font-loader))
 549   ;; FIXME: this vector is sorted by platform ID, encoding ID,
 550   ;; language ID, and name ID, in that order. Could bisect if it
 551   ;; mattered.
 552   (loop for name-entry across (name-entries font-loader)
 553         when (and (or (null platform-id)
 554                       (= (platform-id name-entry) platform-id))
 555                   (or (null encoding-id)
 556                       (= (encoding-id name-entry) encoding-id))
 557                   (or (null language-id)
 558                       (= (language-id name-entry) language-id))
 559                   (or (null name-id)
 560                       (= (name-id name-entry) name-id)))
 561         return name-entry))
 562
 563 (defmethod name-entry-value (name-designator (font-loader font-loader))
 564   (let* ((name-id (etypecase name-designator
 565                     (keyword (name-identifier-id name-designator))
 566                     (integer name-designator)))
 567          (entry (or (find-name-entry +unicode-platform-id+
 568                                      +unicode-2.0-encoding-id+
 569                                      +unicode-language-id+
 570                                      name-id
 571                                      font-loader)
 572                     (find-name-entry +microsoft-platform-id+
 573                                      nil
 574                                      +microsoft-us-english-language-id+
 575                                      name-id
 576                                      font-loader)
 577                     (find-name-entry +macintosh-platform-id+
 578                                      +macintosh-roman-encoding-id+
 579                                      +macintosh-english-language-id+
 580                                      name-id
 581                                      font-loader))))
 582     (when entry
 583       (value entry))))
 584
 585
 586 (defmethod postscript-name ((font-loader font-loader))
 587   (name-entry-value :postscript-name font-loader))
 588
 589 (defmethod family-name ((font-loader font-loader))
 590   (name-entry-value :font-family font-loader))
 591
 592 (defmethod subfamily-name ((font-loader font-loader))
 593   (name-entry-value :font-subfamily font-loader))
 594
 595 (defmethod full-name ((font-loader font-loader))
 596   (name-entry-value :full-name font-loader))