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