cwiki-common.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'char-db-util)
   3 ;; (require 'concord-images)
   4
   5 (setq file-name-coding-system 'utf-8-mcs-er)
   6
   7
   8 (concord-assign-genre 'image-resource "/usr/local/var/photo/db")
   9 (concord-assign-genre 'glyph-image "/usr/local/var/photo/db")
  10
  11 (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
  12 (concord-assign-genre 'person-name@ruimoku "/usr/local/var/ruimoku/db")
  13
  14 (concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
  15 (concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
  16 (concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
  17
  18 (concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
  19 (concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
  20 (concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
  21 (concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
  22 (concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
  23 (concord-assign-genre 'journal-name@ruimoku "/usr/local/var/ruimoku/db")
  24 (concord-assign-genre 'publisher@ruimoku "/usr/local/var/ruimoku/db")
  25 (concord-assign-genre 'publisher-name@ruimoku "/usr/local/var/ruimoku/db")
  26
  27 (mount-char-attribute-table '*instance@ruimoku/bibliography/title)
  28 ;; (mount-char-attribute-table '*instance@ruimoku/bibliography/content*note)
  29
  30 (concord-assign-genre 'entry@zh-classical "/usr/local/var/kanbun/db")
  31 ;; (concord-assign-genre 'morpheme-entry@zh-classical "/usr/local/var/kanbun/db")
  32 (concord-assign-genre 'word-class@zh-classical "/usr/local/var/kanbun/db")
  33 (concord-assign-genre 'morpheme@zh-classical "/usr/local/var/kanbun/db")
  34 (concord-assign-genre 'sentence@zh-classical "/usr/local/var/kanbun/db")
  35 ;; (concord-assign-genre 'sentence-entry@zh-classical "/usr/local/var/kanbun/db")
  36
  37 (mount-char-attribute-table '*instance@morpheme-entry/zh-classical)
  38
  39
  40 (concord-assign-genre 'hng-card "/usr/local/var/hng-card/db")
  41
  42 (mount-char-attribute-table '->HNG)
  43 (mount-char-attribute-table '<-HNG)
  44
  45
  46 (defvar est-hide-cgi-mode nil)
  47 (defvar est-view-url-prefix "..")
  48 (defvar chise-wiki-view-url "view.cgi")
  49 (defvar chise-wiki-edit-url "edit.cgi")
  50
  51 (defvar chise-wiki-bitmap-glyphs-url
  52   "http://www.chise.org/glyphs")
  53
  54 (defvar chise-wiki-hng-bitmap-glyphs-url
  55   "http://hng.chise.org/glyphs/HNG")
  56
  57 (defvar chise-wiki-glyph-cgi-url
  58   "http://www.chise.org/chisewiki/glyph.cgi")
  59
  60 (defvar chise-wiki-displayed-features nil)
  61
  62 (defvar est-coded-charset-priority-list
  63   '(; =ucs
  64     =cns11643-1 =cns11643-2 =cns11643-3
  65     =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
  66     =gb2312 =gb12345
  67     =jis-x0208 =jis-x0208@1990
  68     =jis-x0213-2
  69     =jis-x0212
  70     =adobe-japan1
  71     =cbeta =jef-china3
  72     =jis-x0213-1@2000 =jis-x0213-1@2004
  73     =jis-x0208@1983 =jis-x0208@1978
  74     =zinbun-oracle =>zinbun-oracle
  75     =daikanwa
  76     =gt =gt-k
  77     =>>>adobe-japan1
  78     =>>>jis-x0208 =>>>jis-x0213-1 =>>>jis-x0213-2
  79     =>>jis-x0208 =>>jis-x0213-1 =>>jis-x0213-2
  80     =>>adobe-japan1
  81     =+>jis-x0208 =+>jis-x0213-1 =+>jis-x0213-2
  82     =+>jis-x0208@1978
  83     =+>adobe-japan1
  84     =>jis-x0208 =>jis-x0213-1
  85     =>>gt
  86     =>ucs@iso =>ucs@unicode
  87     =>ucs@jis =>ucs@cns =>ucs@ks
  88     =+>ucs@iso =+>ucs@unicode
  89     =>>ucs@iso =>>ucs@unicode
  90     =>>ucs@jis =>>ucs@cns =>>ucs@ks
  91     =>>>ucs@iso =>>>ucs@unicode
  92     =>>>ucs@jis =>>>ucs@cns =>>>ucs@ks
  93     ===ucs@iso
  94     =ruimoku-v6
  95     =big5
  96     =big5-cdp
  97     =>cbeta
  98     =mj
  99     ==mj
 100     ===mj
 101     =ucs-itaiji-001
 102     =ucs-itaiji-002
 103     =ucs-itaiji-003
 104     =ucs-itaiji-004
 105     =ucs-itaiji-005
 106     =ucs-itaiji-006
 107     =ucs-itaiji-007
 108     =ucs-itaiji-008
 109     =ucs-itaiji-009
 110     =ucs-itaiji-010
 111     =ucs-itaiji-011
 112     =ucs-itaiji-084
 113     =ucs-var-001
 114     =ucs-var-002
 115     =ucs-var-003
 116     =ucs-var-004
 117     =ucs@unicode
 118     ==ucs@unicode
 119     ===ucs@unicode
 120     ==>ucs@bucs
 121     ===daikanwa/+p
 122     ===gt
 123     =>ucs@iwds-1
 124     =>ucs@component
 125     =>ucs-itaiji-001
 126     =>ucs-itaiji-002
 127     =>ucs-itaiji-003
 128     =>ucs-itaiji-004
 129     =>ucs-itaiji-005
 130     =>ucs-itaiji-006
 131     =>ucs-itaiji-007
 132     ===adobe-japan1
 133     ===cns11643-1 ===cns11643-2 ===cns11643-3
 134     ===cns11643-4 ===cns11643-5 ===cns11643-6 ===cns11643-7
 135     ))
 136
 137 (defun decode-uri-string (string &optional coding-system)
 138   (if (> (length string) 0)
 139       (let ((i 0)
 140             dest)
 141         (setq string
 142               (mapconcat (lambda (char)
 143                            (if (eq char ?+)
 144                                " "
 145                              (char-to-string char)))
 146                          string ""))
 147         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
 148           (setq dest (concat dest
 149                              (substring string i (match-beginning 0))
 150                              (char-to-string
 151                               (int-char
 152                                (string-to-int (match-string 1 string) 16))))
 153                 i (match-end 0)))
 154         (decode-coding-string
 155          (concat dest (substring string i))
 156          coding-system))))
 157
 158 (defun www-feature-type (feature-name)
 159   (or (char-feature-property feature-name 'type)
 160       (let ((str (symbol-name feature-name)))
 161         (cond
 162          ((string-match "\\*note\\(@[^*]+\\)?$" str)
 163           'stext)
 164          ((string-match "\\*sources\\(@[^*]+\\)?$" str)
 165           'domain-list)
 166          ((string-match "\\*" str)
 167           nil)
 168          ((string-match "^\\(->\\|<-\\)" str)
 169           'relation)
 170          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
 171           'structure)
 172          ))))
 173
 174 (defun www-feature-format (feature-name)
 175   (or (char-feature-property feature-name 'presentation-format)
 176       (char-feature-property feature-name 'format)
 177       (let (fn parent ret)
 178         (setq fn feature-name)
 179         (while (and (setq parent (char-feature-name-parent fn))
 180                     (null (setq ret
 181                                 (char-feature-property
 182                                  parent 'format))))
 183           (setq fn parent))
 184         ret)
 185       '((name) " : " (value))))
 186
 187 (defun www-feature-value-format (feature-name)
 188   (or (char-feature-property feature-name 'value-presentation-format)
 189       (char-feature-property feature-name 'value-format)
 190       (let (fn parent ret)
 191         (setq fn feature-name)
 192         (while (and (setq parent (char-feature-name-parent fn))
 193                     (null (setq ret
 194                                 (or (char-feature-property
 195                                      parent 'value-presentation-format)
 196                                     (char-feature-property
 197                                      parent 'value-format)))))
 198           (setq fn parent))
 199         ret)
 200       (let ((type (www-feature-type feature-name)))
 201         (cond ((eq type 'relation)
 202                'space-separated)
 203               ((eq type 'structure)
 204                'space-separated-ids)
 205               ((eq type 'stext)
 206                'wiki-text)
 207               ))
 208       (if (find-charset feature-name)
 209           (if (and (= (charset-dimension feature-name) 2)
 210                    (= (charset-chars feature-name) 94))
 211               '("0x" (HEX)
 212                 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
 213             '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))
 214       'space-separated))
 215
 216 (defun char-feature-name-at-domain (feature-name domain)
 217   (if domain
 218       (let ((name (symbol-name feature-name)))
 219         (cond
 220          ((string-match "@[^*]+$" name)
 221           (intern (format "%s/%s" name domain))
 222           )
 223          (t
 224           (intern (format "%s@%s" name domain))
 225           )))
 226     feature-name))
 227
 228 (defun char-feature-name-parent (feature-name)
 229   (let ((name (symbol-name feature-name)))
 230     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 231         (intern (substring name 0 (car (last (match-data) 2)))))))
 232
 233 (defun char-feature-name-domain (feature-name)
 234   (let ((name (symbol-name feature-name)))
 235     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 236         (intern (substring name (1+ (match-beginning 0)))))))
 237
 238 (defun char-feature-name-sans-versions (feature)
 239   (let ((feature-name (symbol-name feature)))
 240     (if (string-match "[@/]\\$rev=latest$" feature-name)
 241         (intern (substring feature-name 0 (match-beginning 0)))
 242       feature)))
 243
 244 (defun est-object-genre (object)
 245   (if (characterp object)
 246       'character
 247     (concord-object-genre object)))
 248
 249 (defun www-get-feature-value (object feature)
 250   (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
 251     (cond
 252      ((characterp object)
 253       (mount-char-attribute-table latest-feature)
 254       (or (char-feature object latest-feature)
 255           (char-feature object feature))
 256       )
 257      (t
 258       (or (condition-case nil
 259               (concord-object-get object latest-feature)
 260             (error nil))
 261           (condition-case nil
 262               (concord-object-get object feature)
 263             (error nil)))
 264       ))))
 265
 266 (defun get-previous-code-point (ccs code)
 267   (let ((chars (charset-chars ccs))
 268         (dim (charset-dimension ccs))
 269         (i 0)
 270         mask byte-min byte-max
 271         bytes dest)
 272     (cond
 273      ((= chars 94)
 274       (setq mask #x7F
 275             byte-min 33
 276             byte-max 126)
 277       )
 278      ((= chars 96)
 279       (setq mask #x7F
 280             byte-min 32
 281             byte-max 127)
 282       )
 283      ((= chars 128)
 284       (setq mask #x7F
 285             byte-min 0
 286             byte-max #xFF)
 287       )
 288      (t ; (= chars 256)
 289       (setq mask #xFF
 290             byte-min 0
 291             byte-max #xFF)
 292       ))
 293     (setq bytes (make-vector dim 0))
 294     (while (< i dim)
 295       (aset bytes i (logand (lsh code (* i -8)) mask))
 296       (setq i (1+ i)))
 297     (setq i 0)
 298     (while (and (< i dim)
 299                 (progn
 300                   (aset bytes i (1- (aref bytes i)))
 301                   (< (aref bytes i) byte-min)))
 302       (aset bytes i byte-max)
 303       (setq i (1+ i)))
 304     (when (< i dim)
 305       (setq dest (aref bytes 0)
 306             i 1)
 307       (while (< i dim)
 308         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 309               i (1+ i)))
 310       dest)))
 311
 312 (defun get-next-code-point (ccs code)
 313   (let ((chars (charset-chars ccs))
 314         (dim (charset-dimension ccs))
 315         (i 0)
 316         mask byte-min byte-max
 317         bytes dest)
 318     (cond
 319      ((= chars 94)
 320       (setq mask #x7F
 321             byte-min 33
 322             byte-max 126)
 323       )
 324      ((= chars 96)
 325       (setq mask #x7F
 326             byte-min 32
 327             byte-max 127)
 328       )
 329      ((= chars 128)
 330       (setq mask #x7F
 331             byte-min 0
 332             byte-max #xFF)
 333       )
 334      (t ; (= chars 256)
 335       (setq mask #xFF
 336             byte-min 0
 337             byte-max #xFF)
 338       ))
 339     (setq bytes (make-vector dim 0))
 340     (while (< i dim)
 341       (aset bytes i (logand (lsh code (* i -8)) mask))
 342       (setq i (1+ i)))
 343     (setq i 0)
 344     (while (and (< i dim)
 345                 (progn
 346                   (aset bytes i (1+ (aref bytes i)))
 347                   (> (aref bytes i) byte-max)))
 348       (aset bytes i byte-min)
 349       (setq i (1+ i)))
 350     (when (< i dim)
 351       (setq dest (aref bytes 0)
 352             i 1)
 353       (while (< i dim)
 354         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 355               i (1+ i)))
 356       dest)))
 357
 358 (defun find-previous-defined-code-point (ccs code)
 359   (let ((i (get-previous-code-point ccs code))
 360         char)
 361     (cond
 362      ((eq ccs '=jis-x0208)
 363       (setq ccs '=jis-x0208@1990))
 364      ((eq ccs '=jis-x0213-1)
 365       (setq ccs '=jis-x0213-1@2004)))
 366     (while (and i
 367                 (>= i 0)
 368                 (null (setq char (decode-char ccs i
 369                                               (unless (eq ccs '=ucs)
 370                                                 'defined-only)))))
 371       (setq i (get-previous-code-point ccs i)))
 372     char))
 373
 374 (defun find-next-defined-code-point (ccs code)
 375   (let ((i (get-next-code-point ccs code))
 376         max char)
 377     (setq max (+ code 1000))
 378     (cond
 379      ((eq ccs '=jis-x0208)
 380       (setq ccs '=jis-x0208@1990))
 381      ((eq ccs '=jis-x0213-1)
 382       (setq ccs '=jis-x0213-1@2004)))
 383     (while (and i
 384                 (<= i max)
 385                 (null (setq char (decode-char ccs i
 386                                               (unless (eq ccs '=ucs)
 387                                                 'defined-only)))))
 388       (setq i (get-next-code-point ccs i)))
 389     char))
 390
 391
 392 ;;; @ URI representation
 393 ;;;
 394
 395 (defun est-uri-decode-feature-name-body (uri-feature)
 396   (let ((len (length uri-feature))
 397         (i 0)
 398         ch dest)
 399     (while (< i len)
 400       (setq dest
 401             (concat
 402              dest
 403              (if (eq (aref uri-feature i) ?\.)
 404                  (if (and (< (+ i 2) len)
 405                           (eq (aref uri-feature (+ i 2)) ?\.))
 406                      (prog1
 407                          (cond
 408                           ((eq (setq ch (aref uri-feature (1+ i))) ?\.)
 409                            "/")
 410                           ((eq ch ?-)
 411                            "*")
 412                           (t
 413                            (substring uri-feature i (+ i 3))
 414                            ))
 415                        (setq i (+ i 3)))
 416                    (setq i (1+ i))
 417                    ".")
 418                (prog1
 419                    (char-to-string (aref uri-feature i))
 420                  (setq i (1+ i)))))))
 421     dest))
 422
 423 (defun est-uri-encode-feature-name-body (feature)
 424   (mapconcat (lambda (c)
 425                (cond ((eq c ?*)
 426                       ".-.")
 427                      ((eq c ?/)
 428                       "...")
 429                      (t (char-to-string c))))
 430              feature ""))
 431
 432 (defun www-uri-decode-feature-name (uri-feature)
 433   (let (feature)
 434     (setq uri-feature (decode-uri-string uri-feature 'utf-8-mcs-er))
 435     (cond
 436      ((string-match "^from\\." uri-feature)
 437       (intern (format "<-%s"
 438                       (est-uri-decode-feature-name-body
 439                        (substring uri-feature (match-end 0)))))
 440       )
 441      ((string-match "^to\\." uri-feature)
 442       (intern (format "->%s"
 443                       (est-uri-decode-feature-name-body
 444                        (substring uri-feature (match-end 0)))))
 445       )
 446      ((string-match "^rep\\." uri-feature)
 447       (intern (format "=%s"
 448                       (est-uri-decode-feature-name-body
 449                        (substring uri-feature (match-end 0)))))
 450       )
 451      ((string-match "^rep[2i]\\." uri-feature)
 452       (intern (format "===%s"
 453                       (est-uri-decode-feature-name-body
 454                        (substring uri-feature (match-end 0)))))
 455       )
 456      ((string-match "^g\\." uri-feature)
 457       (intern (format "=>>%s"
 458                       (est-uri-decode-feature-name-body
 459                        (substring uri-feature (match-end 0)))))
 460       )
 461      ((string-match "^g[i2]\\." uri-feature)
 462       (intern (format "==%s"
 463                       (est-uri-decode-feature-name-body
 464                        (substring uri-feature (match-end 0)))))
 465       )
 466      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
 467       (intern (format "=>>%s%s"
 468                       (make-string (string-to-int
 469                                     (match-string 1 uri-feature))
 470                                    ?>)
 471                       (est-uri-decode-feature-name-body
 472                        (substring uri-feature (match-end 0)))))
 473       )
 474      ((string-match "^o\\." uri-feature)
 475       (intern (format "=+>%s"
 476                       (est-uri-decode-feature-name-body
 477                        (substring uri-feature (match-end 0)))))
 478       )
 479      ((string-match "^a\\." uri-feature)
 480       (intern (format "=>%s"
 481                       (est-uri-decode-feature-name-body
 482                        (substring uri-feature (match-end 0)))))
 483       )
 484      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 485       (intern (format "%s>%s"
 486                       (make-string (string-to-int
 487                                     (match-string 1 uri-feature))
 488                                    ?=)
 489                       (est-uri-decode-feature-name-body
 490                        (substring uri-feature (match-end 0)))))
 491       )
 492      ((and (setq uri-feature (est-uri-decode-feature-name-body uri-feature))
 493            (setq feature (intern (format "=>%s" uri-feature)))
 494            (find-charset feature))
 495       feature)
 496      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 497            (find-charset feature))
 498       feature)
 499      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 500            (find-charset feature))
 501       feature)
 502      ((and (setq feature (intern (format "=%s" uri-feature)))
 503            (find-charset feature))
 504       feature)
 505      (t (intern uri-feature)))))
 506
 507 (defun www-uri-encode-feature-name (feature-name)
 508   (setq feature-name (symbol-name feature-name))
 509   (cond
 510    ((string-match "^=\\+>\\([^=>]+\\)" feature-name)
 511     (concat "o."
 512             (est-uri-encode-feature-name-body
 513              (substring feature-name (match-beginning 1))))
 514     )
 515    ((string-match "^=\\([^=>]+\\)" feature-name)
 516     (concat "rep."
 517             (est-uri-encode-feature-name-body
 518              (substring feature-name (match-beginning 1))))
 519     )
 520    ((string-match "^==\\([^=>]+\\)" feature-name)
 521     (concat "g2."
 522             (est-uri-encode-feature-name-body
 523              (substring feature-name (match-beginning 1))))
 524     )
 525    ((string-match "^===\\([^=>]+\\)" feature-name)
 526     (concat "repi."
 527             (est-uri-encode-feature-name-body
 528              (substring feature-name (match-beginning 1))))
 529     )
 530    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 531     (concat "g."
 532             (est-uri-encode-feature-name-body
 533              (substring feature-name (match-beginning 1))))
 534     )
 535    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 536     (concat "gi."
 537             (est-uri-encode-feature-name-body
 538              (substring feature-name (match-beginning 1))))
 539     )
 540    ((string-match "^=>>\\(>+\\)" feature-name)
 541     (format "gi%d.%s"
 542             (length (match-string 1 feature-name))
 543             (est-uri-encode-feature-name-body
 544              (substring feature-name (match-end 1))))
 545     )
 546    ((string-match "^=>\\([^=>]+\\)" feature-name)
 547     (concat "a."
 548             (est-uri-encode-feature-name-body
 549              (substring feature-name (match-beginning 1))))
 550     )
 551    ((string-match "^\\(=+\\)>" feature-name)
 552     (format "a%d.%s"
 553             (length (match-string 1 feature-name))
 554             (est-uri-encode-feature-name-body
 555              (substring feature-name (match-end 0))))
 556     )
 557    ((string-match "^->" feature-name)
 558     (concat "to."
 559             (est-uri-encode-feature-name-body
 560              (substring feature-name (match-end 0))))
 561     )
 562    ((string-match "^<-" feature-name)
 563     (concat "from."
 564             (est-uri-encode-feature-name-body
 565              (substring feature-name (match-end 0))))
 566     )
 567    (t (est-uri-encode-feature-name-body feature-name))))
 568
 569 (defun www-uri-make-feature-name-url (uri-genre uri-feature-name uri-object)
 570   (if est-hide-cgi-mode
 571       (format "../feature/%s&%s/%s"
 572               uri-feature-name uri-genre uri-object)
 573     (format "%s?feature=%s&%s=%s"
 574             chise-wiki-view-url uri-feature-name uri-genre uri-object)))
 575
 576 (defun www-uri-decode-object (genre char-rep)
 577   (let (ccs cpos)
 578     (cond
 579      ((string-match (if est-hide-cgi-mode
 580                         "\\(%3D\\|=\\|%3A\\|:\\)"
 581                       "\\(%3A\\|:\\)") char-rep)
 582       (setq ccs (substring char-rep 0 (match-beginning 0))
 583             cpos (substring char-rep (match-end 0)))
 584       (setq ccs (www-uri-decode-feature-name ccs))
 585       (setq cpos (est-uri-decode-feature-name-body cpos))
 586       (cond
 587        ((string-match "^0x" cpos)
 588         (setq cpos
 589               (string-to-number (substring cpos (match-end 0)) 16))
 590         )
 591        (t
 592         (setq cpos (car (read-from-string
 593                          (decode-uri-string
 594                           cpos file-name-coding-system))))
 595         ))
 596       (if (and (eq genre 'character)
 597                (numberp cpos))
 598           (decode-char ccs cpos)
 599         (concord-decode-object ccs cpos genre))
 600       )
 601      (t
 602       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 603       (cond
 604        ((eq genre 'character)
 605         (when (= (length char-rep) 1)
 606           (aref char-rep 0))
 607         )
 608        ((eq genre 'feature)
 609         (concord-decode-object
 610          '=id (www-uri-decode-feature-name char-rep) 'feature)
 611         )
 612        (t
 613         (concord-decode-object
 614          '=id (car (read-from-string char-rep)) genre)
 615         ))))))
 616
 617 (defun www-uri-encode-object (object)
 618   (if (characterp object)
 619       (if (encode-char object '=ucs)
 620           (mapconcat
 621            (lambda (byte)
 622              (format "%%%02X" byte))
 623            (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
 624            "")
 625         (let ((ccs-list est-coded-charset-priority-list)
 626               ccs ret)
 627           (while (and ccs-list
 628                       (setq ccs (pop ccs-list))
 629                       (not (setq ret (encode-char object ccs 'defined-only)))))
 630           (cond (ret
 631                  (format (if est-hide-cgi-mode
 632                              "%s=0x%X"
 633                            "%s:0x%X")
 634                          (www-uri-encode-feature-name ccs)
 635                          ret))
 636                 ((and (setq ccs (car (split-char object)))
 637                       (setq ret (encode-char object ccs)))
 638                  (format (if est-hide-cgi-mode
 639                              "%s=0x%X"
 640                            "%s:0x%X")
 641                          (www-uri-encode-feature-name ccs)
 642                          ret))
 643                 (t
 644                  (format (if est-hide-cgi-mode
 645                              "system-char-id=0x%X"
 646                            "system-char-id:0x%X")
 647                          (encode-char object 'system-char-id))
 648                  ))))
 649     (format (if est-hide-cgi-mode
 650                 "rep.id=%s"
 651               "rep.id:%s")
 652             (est-uri-encode-feature-name-body
 653              (format "%s" (concord-object-id object))))))
 654
 655 (defun est-format-object (object &optional readable)
 656   (if (characterp object)
 657       (char-to-string object)
 658     (let ((ret (or (if readable
 659                        (or (concord-object-get object 'name)
 660                            (concord-object-get object '=name)
 661                            (concord-object-get object 'title)))
 662                    (concord-object-id object))))
 663       (format "%s" ret))))
 664
 665 (defun www-uri-make-object-url (object &optional uri-object)
 666   (if est-hide-cgi-mode
 667       (format "%s/%s/%s"
 668               est-view-url-prefix
 669               (est-object-genre object)
 670               (or uri-object
 671                   (www-uri-encode-object object)))
 672     (format "%s?%s=%s"
 673             chise-wiki-view-url
 674             (est-object-genre object)
 675             (or uri-object
 676                 (www-uri-encode-object object)))))
 677
 678
 679 ;;; @ Feature name presentation
 680 ;;;
 681
 682 (defun www-format-feature-name-default (feature-name)
 683   (mapconcat
 684    #'capitalize
 685    (split-string
 686     (symbol-name feature-name)
 687     "-")
 688    " "))
 689
 690 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 691   (let ((str (symbol-name feature-name))
 692         base meta)
 693     (cond
 694      ((string-match "\\*[^*]+$" str)
 695       (setq base (substring str 0 (match-beginning 0))
 696             meta (substring str (match-beginning 0)))
 697       (concat (www-format-feature-name* (intern base) lang)
 698               meta))
 699      (t
 700       (www-format-feature-name-default feature-name)
 701       ))))
 702
 703 (defun www-format-feature-name-as-rel-to (feature-name)
 704   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 705
 706 (defun www-format-feature-name-as-rel-from (feature-name)
 707   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 708
 709 (defun www-format-feature-name-as-CCS (feature-name)
 710   (let* ((rest
 711           (split-string
 712            (symbol-name feature-name)
 713            "-"))
 714          (dest (upcase (pop rest))))
 715     (when (string-match "^=+>*" dest)
 716       (setq dest (concat (substring dest 0 (match-end 0))
 717                          " "
 718                          (substring dest (match-end 0)))))
 719     (cond
 720      (rest
 721       (while (cdr rest)
 722         (setq dest (concat dest " " (upcase (pop rest)))))
 723       (if (string-match "^[0-9]+$" (car rest))
 724           (concat dest "-" (car rest))
 725         (concat dest " " (upcase (car rest))))
 726       )
 727      (t dest))))
 728
 729 (defun www-format-feature-name* (feature-name &optional lang)
 730   (let (name fn parent ret)
 731     (cond
 732      ((or (and lang
 733                (char-feature-property
 734                 feature-name
 735                 (intern (format "name@%s" lang))))
 736           (char-feature-property
 737            feature-name 'name)))
 738      ((and (setq name (symbol-name feature-name))
 739            (string-match "\\*" name))
 740       (www-format-feature-name-as-metadata feature-name lang))
 741      (t
 742       (setq fn feature-name)
 743       (while (and (setq parent (char-feature-name-parent fn))
 744                   (null (setq ret
 745                               (or (and lang
 746                                        (char-feature-property
 747                                         parent
 748                                         (intern (format "name@%s" lang))))
 749                                   (char-feature-property
 750                                    parent 'name)))))
 751         (setq fn parent))
 752       (cond
 753        (ret
 754         (concat ret (substring (symbol-name feature-name)
 755                                (length (symbol-name parent)))))
 756        ((find-charset feature-name)
 757         (www-format-feature-name-as-CCS feature-name))
 758        ((string-match "^\\(->\\)" name)
 759         (www-format-feature-name-as-rel-to feature-name))
 760        ((string-match "^\\(<-\\)" name)
 761         (www-format-feature-name-as-rel-from feature-name))
 762        (t
 763         (www-format-feature-name-default feature-name)
 764         ))
 765       ))))
 766
 767 (defun www-format-feature-name (feature-name &optional lang)
 768   (www-format-encode-string
 769    (www-format-feature-name* feature-name lang)))
 770
 771
 772 ;;; @ HTML generator
 773 ;;;
 774
 775 (defvar www-format-char-img-style "vertical-align:bottom;")
 776
 777 (defun www-format-encode-string (string &optional without-tags as-body)
 778   (with-temp-buffer
 779     (insert string)
 780     (let (plane code subcode start end char variants ret rret)
 781       (when as-body
 782         (goto-char (point-min))
 783         (while (search-forward "&" nil t)
 784           (replace-match "&amp;" nil t)))
 785       (goto-char (point-min))
 786       (while (search-forward "<" nil t)
 787         (replace-match "&lt;" nil t))
 788       (goto-char (point-min))
 789       (while (search-forward ">" nil t)
 790         (replace-match "&gt;" nil t))
 791       (if without-tags
 792           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 793         (let ((coded-charset-entity-reference-alist
 794                (list*
 795                 '(=gt                   "GT-" 5 d)
 796                 '(=mj                    "MJ" 6 d)
 797                 '(=hanyo-denshi/ja   "HD-JA-" 4 X)
 798                 '(=hanyo-denshi/jb   "HD-JB-" 4 X)
 799                 '(=hanyo-denshi/jc   "HD-JC-" 4 X)
 800                 '(=hanyo-denshi/jd   "HD-JD-" 4 X)
 801                 '(=hanyo-denshi/ft   "HD-FT-" 4 X)
 802                 '(=hanyo-denshi/ia   "HD-IA-" 4 X)
 803                 '(=hanyo-denshi/ib   "HD-IB-" 4 X)
 804                 '(=hanyo-denshi/hg   "HD-HG-" 4 X)
 805                 '(=hanyo-denshi/ip   "HD-IP-" 4 X)
 806                 '(=hanyo-denshi/jt   "HD-JT-" 4 X)
 807                 '(=hanyo-denshi/ks   "HD-KS-" 6 d)
 808                 '(=>>hanyo-denshi/ja "G-HD-JA-" 4 X)
 809                 '(=>>hanyo-denshi/jb "G-HD-JB-" 4 X)
 810                 '(=>>hanyo-denshi/jc "G-HD-JC-" 4 X)
 811                 '(=>>hanyo-denshi/jd "G-HD-JD-" 4 X)
 812                 '(=>>hanyo-denshi/ft "G-HD-FT-" 4 X)
 813                 '(=>>hanyo-denshi/ia "G-HD-IA-" 4 X)
 814                 '(=>>hanyo-denshi/ib "G-HD-IB-" 4 X)
 815                 '(=>>hanyo-denshi/hg "G-HD-HG-" 4 X)
 816                 '(=>>hanyo-denshi/ip "G-HD-IP-" 4 X)
 817                 '(=>>hanyo-denshi/jt "G-HD-JT-" 4 X)
 818                 '(=>>hanyo-denshi/ks "G-HD-KS-" 6 d)
 819                 '(==mj                  "g2-MJ" 6 d)
 820                 '(==hanyo-denshi/ja "g2-HD-JA-" 4 X)
 821                 '(==hanyo-denshi/jb "g2-HD-JB-" 4 X)
 822                 '(==hanyo-denshi/jc "g2-HD-JC-" 4 X)
 823                 '(==hanyo-denshi/jd "g2-HD-JD-" 4 X)
 824                 '(==hanyo-denshi/ft "g2-HD-FT-" 4 X)
 825                 '(==hanyo-denshi/ia "g2-HD-IA-" 4 X)
 826                 '(==hanyo-denshi/ib "g2-HD-IB-" 4 X)
 827                 '(==hanyo-denshi/hg "g2-HD-HG-" 4 X)
 828                 '(==hanyo-denshi/ip "g2-HD-IP-" 4 X)
 829                 '(==hanyo-denshi/jt "g2-HD-JT-" 4 X)
 830                 '(==hanyo-denshi/ks "g2-HD-KS-" 6 d)
 831                 '(=cns11643-1           "C1-" 4 X)
 832                 '(=cns11643-2           "C2-" 4 X)
 833                 '(=cns11643-3           "C3-" 4 X)
 834                 '(=cns11643-4           "C4-" 4 X)
 835                 '(=cns11643-5           "C5-" 4 X)
 836                 '(=cns11643-6           "C6-" 4 X)
 837                 '(=cns11643-7           "C7-" 4 X)
 838                 '(=adobe-japan1-6       "AJ1-" 5 d)
 839                 '(=big5-cdp             "CDP-" 4 X)
 840                 '(=gb2312               "G0-" 4 X)
 841                 '(=gb12345              "G1-" 4 X)
 842                 '(=jis-x0208@1990       "J90-" 4 X)
 843                 '(=jis-x0212            "JSP-" 4 X)
 844                 '(=cbeta                "CB" 5 d)
 845                 '(=jis-x0208@1997       "J97-" 4 X)
 846                 '(=jis-x0208@1978       "J78-" 4 X)
 847                 '(=jis-x0208@1983       "J83-" 4 X)
 848                 '(=ruimoku-v6           "RUI6-" 4 X)
 849                 '(=zinbun-oracle        "ZOB-" 4 d)
 850                 '(=jef-china3           "JC3-" 4 X)
 851                 '(=ucs@unicode          "UU+" 4 X)
 852                 '(=ucs@JP/hanazono  "hanaJU+" 4 X)
 853                 '(==cns11643-1        "R-C1-" 4 X)
 854                 '(==cns11643-2        "R-C2-" 4 X)
 855                 '(==cns11643-3        "R-C3-" 4 X)
 856                 '(==cns11643-4        "R-C4-" 4 X)
 857                 '(==cns11643-5        "R-C5-" 4 X)
 858                 '(==cns11643-6        "R-C6-" 4 X)
 859                 '(==cns11643-7        "R-C7-" 4 X)
 860                 '(=hanziku-1         "HZK01-" 4 X)
 861                 '(=hanziku-2         "HZK02-" 4 X)
 862                 '(=hanziku-3         "HZK03-" 4 X)
 863                 '(=hanziku-4         "HZK04-" 4 X)
 864                 '(=hanziku-5         "HZK05-" 4 X)
 865                 '(=hanziku-6         "HZK06-" 4 X)
 866                 '(=hanziku-7         "HZK07-" 4 X)
 867                 '(=hanziku-8         "HZK08-" 4 X)
 868                 '(=hanziku-9         "HZK09-" 4 X)
 869                 '(=hanziku-10        "HZK10-" 4 X)
 870                 '(=hanziku-11        "HZK11-" 4 X)
 871                 '(=hanziku-12        "HZK12-" 4 X)
 872                 '(=big5                  "B-" 4 X)
 873                 '(=daikanwa              "M-" 5 d)
 874                 coded-charset-entity-reference-alist)))
 875           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 876
 877           (goto-char (point-min))
 878           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\)?CB\\([0-9]+\\);" nil t)
 879             (setq code (string-to-int (match-string 2)))
 880             (replace-match
 881              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
 882 style=\"%s\">"
 883                      code
 884                      chise-wiki-bitmap-glyphs-url
 885                      (/ code 1000) code
 886                      www-format-char-img-style)
 887              t 'literal))
 888
 889           (goto-char (point-min))
 890           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 891             (setq plane (match-string 2)
 892                   code (string-to-int (match-string 3) 16))
 893             (replace-match
 894              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
 895 style=\"%s\">"
 896                      plane code
 897                      chise-wiki-bitmap-glyphs-url
 898                      plane
 899                      (- (lsh code -8) 32)
 900                      (- (logand code 255) 32)
 901                      www-format-char-img-style)
 902              t 'literal))
 903
 904           (goto-char (point-min))
 905           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 906             (setq code (string-to-int (match-string 2) 16))
 907             (replace-match
 908              (format "<img alt=\"J0-%04X\" src=\"%s/JIS-90/%02d-%02d.gif\"
 909 style=\"%s\">"
 910                      code
 911                      chise-wiki-bitmap-glyphs-url
 912                      (- (lsh code -8) 32)
 913                      (- (logand code 255) 32)
 914                      www-format-char-img-style)
 915              t 'literal))
 916
 917           (goto-char (point-min))
 918           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(JA\\|JB\\|JC\\|JD\\|FT\\|IA\\|IB\\|HG\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 919             (setq plane (match-string 2)
 920                   code (string-to-int (match-string 3) 16))
 921             (replace-match
 922              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%02d%02d.png\"
 923 style=\"%s\">"
 924                      plane code
 925                      chise-wiki-bitmap-glyphs-url
 926                      plane
 927                      (- (lsh code -8) 32)
 928                      (- (logand code 255) 32)
 929                      www-format-char-img-style)
 930              t 'literal))
 931
 932           (goto-char (point-min))
 933           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-\\(IP\\|JT\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 934             (setq plane (match-string 2)
 935                   code (string-to-int (match-string 3) 16))
 936             (replace-match
 937              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%04X.png\"
 938 style=\"%s\">"
 939                      plane code
 940                      chise-wiki-bitmap-glyphs-url
 941                      plane code
 942                      www-format-char-img-style)
 943              t 'literal))
 944
 945           (goto-char (point-min))
 946           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-KS-\\([0-9]+\\);" nil t)
 947             (setq code (string-to-int (match-string 2)))
 948             (replace-match
 949              (format "<img alt=\"HD-KS%06d\" src=\"%s/IVD/HanyoDenshi/KS%06d.png\"
 950 style=\"vertical-align:middle\">"
 951                      code
 952                      chise-wiki-bitmap-glyphs-url
 953                      code
 954                      www-format-char-img-style)
 955              t 'literal))
 956
 957           (goto-char (point-min))
 958           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 959             (setq plane (string-to-int (match-string 1))
 960                   code (string-to-int (match-string 2) 16))
 961             (replace-match
 962              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
 963 style=\"%s\">"
 964                      plane code
 965                      chise-wiki-bitmap-glyphs-url
 966                      plane
 967                      (- (lsh code -8) 32)
 968                      (- (logand code 255) 32)
 969                      www-format-char-img-style)
 970              t 'literal))
 971
 972           (goto-char (point-min))
 973           (while (re-search-forward "&\\(R-\\)?C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 974             (setq plane (string-to-int (match-string 2))
 975                   code (string-to-int (match-string 3) 16))
 976             (replace-match
 977              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
 978 style=\"%s\">"
 979                      plane code
 980                      chise-wiki-bitmap-glyphs-url
 981                      plane code
 982                      www-format-char-img-style)
 983              t 'literal))
 984
 985           (goto-char (point-min))
 986           (while (re-search-forward "&\\(R-\\)?JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 987             (setq code (string-to-int (match-string 2) 16))
 988             (replace-match
 989              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 990                      code code)
 991              t 'literal))
 992
 993           (goto-char (point-min))
 994           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 995             (setq code (string-to-int (match-string 2)))
 996             (replace-match
 997              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
 998 style=\"vertical-align:middle\">"
 999                      code
1000                      chise-wiki-bitmap-glyphs-url
1001                      code
1002                      www-format-char-img-style)
1003              t 'literal))
1004
1005           (goto-char (point-min))
1006           (while (re-search-forward "&HNG\\([0-9]+\\)-\\([0-9][0-9][0-9][0-9]\\)\\([0-9]\\);" nil t)
1007             (setq plane (match-string 1)
1008                   code (string-to-int (match-string 2))
1009                   subcode (string-to-int (match-string 3)))
1010             (setq subcode
1011                   (if (eq subcode 0)
1012                       ""
1013                     (char-to-string (decode-char 'ascii (+ 96 subcode)))))
1014             (replace-match
1015              (format
1016               "<div class=\"tooltip\"><img alt=\"HNG%s-%04d%s\" src=\"%s/%s/%04d%s.png\" style=\"
1017 vertical-align:middle; width: 48px; height: 48px\"><span
1018 class=\"tooltiptext\">%s</span></div>"
1019               plane code subcode
1020               chise-wiki-hng-bitmap-glyphs-url
1021               plane code subcode
1022               (charset-description
1023                (car (find (format "HNG%s-" plane)
1024                           coded-charset-entity-reference-alist
1025                           :test (lambda (key cell)
1026                                   (string= key (nth 1 cell))))))
1027               )
1028              t 'literal))
1029
1030           (goto-char (point-min))
1031           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?AJ1-\\([0-9]+\\);" nil t)
1032             (setq code (string-to-int (match-string 2)))
1033             (replace-match
1034              (format "<img alt=\"AJ1-%05d\" src=\"%s/IVD/AdobeJapan1/CID+%d.png\"
1035 style=\"vertical-align:middle\">"
1036                      code
1037                      chise-wiki-bitmap-glyphs-url
1038                      code
1039                      www-format-char-img-style)
1040              t 'literal))
1041
1042           (goto-char (point-min))
1043           (while (re-search-forward "&\\(A-\\|o-\\|G-\\|g2-\\|R-\\)?MJ\\([0-9]+\\);" nil t)
1044             (setq code (string-to-int (match-string 2)))
1045             (replace-match
1046              (format "<img alt=\"MJ%06d\" src=\"http://mojikiban.ipa.go.jp/search/MJ%06d\"
1047 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1048                      code
1049                      code
1050                      www-format-char-img-style)
1051              t 'literal))
1052
1053           (goto-char (point-min))
1054           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\)?IU[+-]\\([0-9A-F]+\\);" nil t)
1055             (setq code (string-to-int (match-string 2) 16))
1056             (replace-match
1057              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1058 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1059                      code
1060                      code
1061                      www-format-char-img-style)
1062              t 'literal))
1063
1064           (goto-char (point-min))
1065           (while (re-search-forward "&A-compU[+-]\\([0-9A-F]+\\);" nil t)
1066             (setq code (string-to-int (match-string 1) 16))
1067             (replace-match
1068              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1069 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1070                      code
1071                      code
1072                      www-format-char-img-style)
1073              t 'literal))
1074
1075           (goto-char (point-min))
1076           (while (re-search-forward
1077                   "&\\(A-\\)?U-i\\([0-9]+\\)\\+\\([0-9A-F]+\\);"
1078                   nil t)
1079             (setq plane (string-to-int (match-string 2))
1080                   code (string-to-int (match-string 3) 16))
1081             (replace-match
1082              (format "<img alt=\"u%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-itaiji-%03d.100px.png\"
1083 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1084                      code
1085                      plane
1086                      code
1087                      plane
1088                      www-format-char-img-style)
1089              t 'literal))
1090
1091           (goto-char (point-min))
1092           (while (re-search-forward "&A-IWDSU\\+\\([0-9A-F]+\\);" nil t)
1093             (setq code (string-to-int (match-string 1) 16))
1094             (replace-match
1095              (format "<img alt=\"A-IWDSU+%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1096 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1097                      code
1098                      code
1099                      www-format-char-img-style)
1100              t 'literal))
1101
1102           (goto-char (point-min))
1103           (while (re-search-forward
1104                   "&\\(A-\\)?CDP-i\\([0-9]+\\)-\\([0-9A-F]+\\);"
1105                   nil t)
1106             (setq plane (string-to-int (match-string 2))
1107                   code (string-to-int (match-string 3) 16))
1108             (replace-match
1109              (format "<img alt=\"u%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/cdp-%04x-itaiji-%03d.100px.png\"
1110 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1111                      code
1112                      plane
1113                      code
1114                      plane
1115                      www-format-char-img-style)
1116              t 'literal))
1117
1118           (goto-char (point-min))
1119           (while (re-search-forward "&U-v\\([0-9]+\\)\\+\\([0-9A-F]+\\);" nil t)
1120             (setq plane (string-to-int (match-string 1))
1121                   code (string-to-int (match-string 2) 16))
1122             (replace-match
1123              (format "<img alt=\"u%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-var-%03d.100px.png\"
1124 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1125                      code
1126                      plane
1127                      code
1128                      plane
1129                      www-format-char-img-style)
1130              t 'literal))
1131
1132           (goto-char (point-min))
1133           (while (re-search-forward "&\\(A-\\|G-\\|R-\\|g2-\\)?GT-\\([0-9]+\\);" nil t)
1134             (setq code (string-to-int (match-string 2)))
1135             (replace-match
1136              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
1137 style=\"%s\">"
1138                      code
1139                      chise-wiki-glyph-cgi-url
1140                      code
1141                      www-format-char-img-style)
1142              t 'literal))
1143
1144           (goto-char (point-min))
1145           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\)?GT-K\\([0-9]+\\);" nil t)
1146             (setq code (string-to-int (match-string 2)))
1147             (replace-match
1148              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
1149 style=\"%s\">"
1150                      code
1151                      chise-wiki-glyph-cgi-url
1152                      code
1153                      www-format-char-img-style)
1154              t 'literal))
1155
1156           (goto-char (point-min))
1157           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
1158             (setq code (string-to-int (match-string 1) 16))
1159             (replace-match
1160              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
1161 style=\"%s\">"
1162                      code
1163                      chise-wiki-glyph-cgi-url
1164                      code
1165                      www-format-char-img-style)
1166              t 'literal))
1167
1168           (goto-char (point-min))
1169           (while (re-search-forward
1170                   "&\\(A-\\|G-\\|g2-\\|R-\\)?CDP-\\([0-9A-F]+\\);" nil t)
1171             (setq code (string-to-int (match-string 2) 16))
1172             (replace-match
1173              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
1174 style=\"%s\">"
1175                      code
1176                      chise-wiki-glyph-cgi-url
1177                      code
1178                      www-format-char-img-style)
1179              t 'literal))
1180
1181           (goto-char (point-min))
1182           (while (re-search-forward
1183                   "&\\(I-\\)?HZK\\(0[1-9]\\|1[0-2]\\)-\\([0-9A-F]+\\);" nil t)
1184             (setq plane (match-string 2)
1185                   code (string-to-int (match-string 3) 16))
1186             (replace-match
1187              (format "<img alt=\"HZK%s-%04X\" src=\"%s?char=HZK%s-%04X\"
1188 style=\"%s\">"
1189                      plane
1190                      code
1191                      chise-wiki-glyph-cgi-url
1192                      plane
1193                      code
1194                      www-format-char-img-style)
1195              t 'literal))
1196
1197           (goto-char (point-min))
1198           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?RUI6-\\([0-9A-F]+\\);" nil t)
1199             (setq code (string-to-int (match-string 2) 16))
1200             (replace-match
1201              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
1202 style=\"vertical-align:middle\">"
1203                      code
1204                      chise-wiki-glyph-cgi-url
1205                      code
1206                      www-format-char-img-style)
1207              t 'literal))
1208
1209           (goto-char (point-min))
1210           (while (re-search-forward "&hanaJU\\+\\([0-9A-F]+\\);" nil t)
1211             (setq code (string-to-int (match-string 1) 16))
1212             (replace-match
1213              (format "<img alt=\"hanaJU+%04X\" src=\"%s?char=hana-JU+%04X\"
1214 style=\"vertical-align:middle\">"
1215                      code
1216                      chise-wiki-glyph-cgi-url
1217                      code
1218                      www-format-char-img-style)
1219              t 'literal))
1220
1221           (goto-char (point-min))
1222           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
1223             (setq code (string-to-int (match-string 3) 16))
1224             (replace-match
1225              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
1226 style=\"vertical-align:middle\">"
1227                      code
1228                      code
1229                      www-format-char-img-style)
1230              t 'literal))
1231
1232           (goto-char (point-min))
1233           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
1234             (setq code (string-to-int (match-string 1) 16))
1235             (setq start (match-beginning 0)
1236                   end (match-end 0))
1237             (setq char (decode-char 'system-char-id code))
1238             (cond
1239              ((and (setq variants
1240                          (or (www-get-feature-value char '->subsumptive)
1241                              (www-get-feature-value char '->denotational)))
1242                    (progn
1243                      (if (characterp variants)
1244                          (setq variants (list variants)))
1245                      (while (and variants
1246                                  (setq ret (www-format-encode-string
1247                                             (char-to-string (car variants))))
1248                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
1249                        (setq variants (cdr variants)))
1250                      ret))
1251               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
1252                 (goto-char start)
1253                 (delete-region start end)
1254                 (insert ret))
1255               )
1256              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
1257                             (www-get-feature-value char 'ideographic-structure)))
1258               (setq ret
1259                     (mapconcat
1260                      (lambda (ch)
1261                        (if (listp ch)
1262                            (if (characterp (setq rret (find-char ch)))
1263                                (setq ch rret)))
1264                        (if (characterp ch)
1265                            (www-format-encode-string
1266                             (char-to-string ch) without-tags)
1267                          (www-format-encode-string
1268                           (format "%S" ch) without-tags)))
1269                      ret ""))
1270               (when ret
1271                 (goto-char start)
1272                 (delete-region start end)
1273                 (insert ret))
1274               )))
1275           ))
1276       ;; (goto-char (point-min))
1277       ;; (while (search-forward "&GT-" nil t)
1278       ;;   (replace-match "&amp;GT-" t 'literal))
1279       (buffer-string))))
1280
1281 (defun www-html-display-text (text)
1282   (princ
1283    (with-temp-buffer
1284      (insert text)
1285      (goto-char (point-min))
1286      (while (search-forward "<" nil t)
1287        (replace-match "&lt;" nil t))
1288      (goto-char (point-min))
1289      (while (search-forward ">" nil t)
1290        (replace-match "&gt;" nil t))
1291      (goto-char (point-min))
1292      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1293        (replace-match
1294         (format "<a href=\"%s\">%s</a>"
1295                 (match-string 2)
1296                 (match-string 1))
1297         nil t))
1298      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1299      (goto-char (point-min))
1300      (while (search-forward "&GT-" nil t)
1301        (replace-match "&amp;GT-" nil t))
1302      (buffer-string))))
1303
1304 (defun www-html-display-paragraph (text)
1305   (princ "<p>")
1306   (www-html-display-text text)
1307   (princ "</p>\n"))
1308
1309
1310 ;;; @ for GlyphWiki
1311 ;;;
1312
1313 (defvar coded-charset-GlyphWiki-id-alist
1314   '((===adobe-japan1-0  "aj1-"  5 d nil)
1315     (===adobe-japan1-1  "aj1-"  5 d nil)
1316     (===adobe-japan1-2  "aj1-"  5 d nil)
1317     (===adobe-japan1-3  "aj1-"  5 d nil)
1318     (===adobe-japan1-4  "aj1-"  5 d nil)
1319     (===adobe-japan1-5  "aj1-"  5 d nil)
1320     (===adobe-japan1-6  "aj1-"  5 d nil)
1321     (===ucs@jis         "u"     4 x nil)
1322     (===daikanwa        "dkw-"  5 d nil)
1323     (===ucs@ks          "u"     4 x "-k")
1324     (=ucs-var-001       "u"     4 x "-var-001")
1325     (=ucs-var-002       "u"     4 x "-var-002")
1326     (=ucs-var-003       "u"     4 x "-var-003")
1327     (=ucs-var-004       "u"     4 x "-var-004")
1328     (=ucs-itaiji-001    "u"     4 x "-itaiji-001")
1329     (=ucs-itaiji-002    "u"     4 x "-itaiji-002")
1330     (=ucs-itaiji-003    "u"     4 x "-itaiji-003")
1331     (=ucs-itaiji-084    "u"     4 x "-itaiji-084")
1332     (=>ucs-itaiji-001   "u"     4 x "-itaiji-001")
1333     (=>ucs-itaiji-006   "u"     4 x "-itaiji-006")
1334     (==adobe-japan1-0   "aj1-"  5 d nil)
1335     (==adobe-japan1-1   "aj1-"  5 d nil)
1336     (==adobe-japan1-2   "aj1-"  5 d nil)
1337     (==adobe-japan1-3   "aj1-"  5 d nil)
1338     (==adobe-japan1-4   "aj1-"  5 d nil)
1339     (==adobe-japan1-5   "aj1-"  5 d nil)
1340     (==adobe-japan1-6   "aj1-"  5 d nil)
1341     (==ucs@jis          "u"     4 x nil)
1342     (==ucs@iso          "u"     4 x nil)
1343     (==ucs@cns          "u"     4 x "-t")
1344     (==ucs@unicode      "u"     4 x "-us")
1345     (==daikanwa         "dkw-"  5 d nil)
1346     (==ucs@ks           "u"     4 x "-k")
1347     (==jis-x0208@1978   "j78-"  4 x nil)
1348     (==jis-x0208        "j90-"  4 x nil)
1349     (==jis-x0208@1990   "j90-"  4 x nil)
1350     (==jis-x0208@1983   "j83-"  4 x nil)
1351     (==cbeta           "cbeta-" 5 d nil)
1352     (=>>hanyo-denshi/ks "koseki-" 6 d nil)
1353     (=>>jis-x0208@1978  "j78-"  4 x nil)
1354     (=>>big5-cdp        "cdp-"  4 x nil)
1355     (=>>jis-x0208       "j90-"  4 x nil)
1356     (=>>jis-x0208@1990  "j90-"  4 x nil)
1357     (=>>jis-x0208@1983  "j83-"  4 x nil)
1358     (=>>daikanwa        "dkw-"  5 d nil)
1359     (=adobe-japan1-0    "aj1-"  5 d nil)
1360     (=adobe-japan1-1    "aj1-"  5 d nil)
1361     (=adobe-japan1-2    "aj1-"  5 d nil)
1362     (=adobe-japan1-3    "aj1-"  5 d nil)
1363     (=adobe-japan1-4    "aj1-"  5 d nil)
1364     (=adobe-japan1-5    "aj1-"  5 d nil)
1365     (=adobe-japan1-6    "aj1-"  5 d nil)
1366     (=decomposition@cid)
1367     (=decomposition@hanyo-denshi)
1368     (=hanyo-denshi/ks   "koseki-" 6 d nil)
1369     (=koseki            "koseki-" 6 d nil)
1370     (=ucs@jis           "u"     4 x nil)
1371     (=ucs@cns           "u"     4 x "-t")
1372     (=ucs@ks            "u"     4 x "-k")
1373     (=ucs@JP            "u"     4 x nil)
1374     (=ucs@gb            "u"     4 x "-g")
1375     (=ucs@iso           "u"     4 x "-u")
1376     (=ucs@unicode       "u"     4 x "-us")
1377     (=big5-cdp          "cdp-"  4 x nil)
1378     (=>big5-cdp         "cdp-"  4 x nil)
1379     (=cbeta            "cbeta-" 5 d nil)
1380     (=big5-cdp-var-3    "cdp-"  4 x "-var-3")
1381     (=big5-cdp-var-5    "cdp-"  4 x "-var-5")
1382     (=big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1383     (=big5-cdp-itaiji-002 "cdp-" 4 x "-itaiji-002")
1384     (=>big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1385     (=jef-china3        "jc3-"  4 x nil)
1386     (=jis-x0212         "jsp-"  4 x nil)
1387     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
1388     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
1389     (=jis-x0213-2       "jx2-"  4 x nil)
1390     (=gt-k              "gt-k"  5 d nil)
1391     (=jis-x0208@1978/1pr "j78-" 4 x nil)
1392     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1393     (=jis-x0208@1978    "j78-"  4 x nil)
1394     (=+>jis-x0208@1978  "j78-"  4 x nil)
1395     (=+>jis-x0208       "j90-"  4 x nil)
1396     (=+>jis-x0208@1990  "j90-"  4 x nil)
1397     (=+>jis-x0208@1983  "j83-"  4 x nil)
1398     (=ucs               "u"     4 x nil)
1399     (=big5              "b-"    4 x nil)
1400     (=daikanwa          "dkw-"  5 d nil)
1401     (=gt                "gt-"   5 d nil)
1402     (=ruimoku-v6        "rui6-" 4 x nil)
1403     (=>ruimoku-v6       "rui6-" 4 x nil)
1404     (=ks-x1001          "k0-"   4 x nil)
1405     (=cns11643-1        "c1-"   4 x nil)
1406     (=cns11643-2        "c2-"   4 x nil)
1407     (=cns11643-3        "c3-"   4 x nil)
1408     (=cns11643-4        "c4-"   4 x nil)
1409     (=cns11643-5        "c5-"   4 x nil)
1410     (=cns11643-6        "c6-"   4 x nil)
1411     (=cns11643-7        "c7-"   4 x nil)
1412     (=jis-x0208         "j90-"  4 x nil)
1413     (=jis-x0208@1990    "j90-"  4 x nil)
1414     (=jis-x0208@1983    "j83-"  4 x nil)
1415     ))
1416
1417 (defun char-GlyphWiki-id (char)
1418   (let ((rest coded-charset-GlyphWiki-id-alist)
1419         spec ret code)
1420     (while (and rest
1421                 (setq spec (pop rest))
1422                 (null (setq ret (char-feature char (car spec))))))
1423     (when ret
1424       (or
1425        (and (listp ret)
1426             (mapconcat #'char-GlyphWiki-id ret "-"))
1427        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1428             (cond
1429              ((and (or (encode-char char '=jis-x0208@1990)
1430                        (encode-char char '=jis-x0212)
1431                        (encode-char char '=jis-x0213-1)
1432                        (encode-char char '=jis-x0213-2))
1433                    (setq code (encode-char char '=ucs@jis)))
1434               (format "u%04x" code)
1435               )
1436              ((and (or (encode-char char '=gb2312)
1437                        (encode-char char '=gb12345))
1438                    (setq code (encode-char char '=ucs@gb)))
1439               (format "u%04x-g" code)
1440               )
1441              ((and (or (encode-char char '=cns11643-1)
1442                        (encode-char char '=cns11643-2)
1443                        (encode-char char '=cns11643-3)
1444                        (encode-char char '=cns11643-4)
1445                        (encode-char char '=cns11643-5)
1446                        (encode-char char '=cns11643-6)
1447                        (encode-char char '=cns11643-7))
1448                    (setq code (encode-char char '=ucs@cns)))
1449               (format "u%04x-t" code)
1450               )
1451              ((and (encode-char char '=ks-x1001)
1452                    (setq code (encode-char char '=ucs@ks)))
1453               (format "u%04x-k" code)
1454               )))
1455        (format (format "%s%%0%d%s%s"
1456                        (nth 1 spec)
1457                        (nth 2 spec)
1458                        (nth 3 spec)
1459                        (or (nth 4 spec) ""))
1460                ret)))))
1461
1462
1463 ;;; @ End.
1464 ;;;
1465
1466 (provide 'cwiki-common)
1467
1468 ;;; cwiki-common.el ends here