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                 '(=>big5-cdp          "A-CDP-" 4 X)
 841                 '(=gb2312               "G0-" 4 X)
 842                 '(=gb12345              "G1-" 4 X)
 843                 '(=jis-x0208@1990       "J90-" 4 X)
 844                 '(=jis-x0212            "JSP-" 4 X)
 845                 '(=cbeta                "CB" 5 d)
 846                 '(=jis-x0208@1997       "J97-" 4 X)
 847                 '(=jis-x0208@1978       "J78-" 4 X)
 848                 '(=jis-x0208@1983       "J83-" 4 X)
 849                 '(=ruimoku-v6           "RUI6-" 4 X)
 850                 '(=zinbun-oracle        "ZOB-" 4 d)
 851                 '(=jef-china3           "JC3-" 4 X)
 852                 '(=ucs@unicode          "UU+" 4 X)
 853                 '(=ucs@JP/hanazono  "hanaJU+" 4 X)
 854                 '(==cns11643-1        "R-C1-" 4 X)
 855                 '(==cns11643-2        "R-C2-" 4 X)
 856                 '(==cns11643-3        "R-C3-" 4 X)
 857                 '(==cns11643-4        "R-C4-" 4 X)
 858                 '(==cns11643-5        "R-C5-" 4 X)
 859                 '(==cns11643-6        "R-C6-" 4 X)
 860                 '(==cns11643-7        "R-C7-" 4 X)
 861                 '(=hanziku-1         "HZK01-" 4 X)
 862                 '(=hanziku-2         "HZK02-" 4 X)
 863                 '(=hanziku-3         "HZK03-" 4 X)
 864                 '(=hanziku-4         "HZK04-" 4 X)
 865                 '(=hanziku-5         "HZK05-" 4 X)
 866                 '(=hanziku-6         "HZK06-" 4 X)
 867                 '(=hanziku-7         "HZK07-" 4 X)
 868                 '(=hanziku-8         "HZK08-" 4 X)
 869                 '(=hanziku-9         "HZK09-" 4 X)
 870                 '(=hanziku-10        "HZK10-" 4 X)
 871                 '(=hanziku-11        "HZK11-" 4 X)
 872                 '(=hanziku-12        "HZK12-" 4 X)
 873                 '(==cbeta               "CB" 5 d)
 874                 '(=big5                  "B-" 4 X)
 875                 '(=daikanwa              "M-" 5 d)
 876                 coded-charset-entity-reference-alist)))
 877           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 878
 879           (goto-char (point-min))
 880           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?CB\\([0-9]+\\);" nil t)
 881             (setq code (string-to-int (match-string 2)))
 882             (replace-match
 883              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
 884 style=\"%s\">"
 885                      code
 886                      chise-wiki-bitmap-glyphs-url
 887                      (/ code 1000) code
 888                      www-format-char-img-style)
 889              t 'literal))
 890
 891           (goto-char (point-min))
 892           (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)
 893             (setq plane (match-string 2)
 894                   code (string-to-int (match-string 3) 16))
 895             (replace-match
 896              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
 897 style=\"%s\">"
 898                      plane code
 899                      chise-wiki-bitmap-glyphs-url
 900                      plane
 901                      (- (lsh code -8) 32)
 902                      (- (logand code 255) 32)
 903                      www-format-char-img-style)
 904              t 'literal))
 905
 906           (goto-char (point-min))
 907           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?J0-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 908             (setq code (string-to-int (match-string 2) 16))
 909             (replace-match
 910              (format "<img alt=\"J0-%04X\" src=\"%s/JIS-90/%02d-%02d.gif\"
 911 style=\"%s\">"
 912                      code
 913                      chise-wiki-bitmap-glyphs-url
 914                      (- (lsh code -8) 32)
 915                      (- (logand code 255) 32)
 916                      www-format-char-img-style)
 917              t 'literal))
 918
 919           (goto-char (point-min))
 920           (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)
 921             (setq plane (match-string 2)
 922                   code (string-to-int (match-string 3) 16))
 923             (replace-match
 924              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%02d%02d.png\"
 925 style=\"%s\">"
 926                      plane code
 927                      chise-wiki-bitmap-glyphs-url
 928                      plane
 929                      (- (lsh code -8) 32)
 930                      (- (logand code 255) 32)
 931                      www-format-char-img-style)
 932              t 'literal))
 933
 934           (goto-char (point-min))
 935           (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)
 936             (setq plane (match-string 2)
 937                   code (string-to-int (match-string 3) 16))
 938             (replace-match
 939              (format "<img alt=\"HD-%s-%04X\" src=\"%s/IVD/HanyoDenshi/%s%04X.png\"
 940 style=\"%s\">"
 941                      plane code
 942                      chise-wiki-bitmap-glyphs-url
 943                      plane code
 944                      www-format-char-img-style)
 945              t 'literal))
 946
 947           (goto-char (point-min))
 948           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?HD-KS-\\([0-9]+\\);" nil t)
 949             (setq code (string-to-int (match-string 2)))
 950             (replace-match
 951              (format "<img alt=\"HD-KS%06d\" src=\"%s/IVD/HanyoDenshi/KS%06d.png\"
 952 style=\"vertical-align:middle\">"
 953                      code
 954                      chise-wiki-bitmap-glyphs-url
 955                      code
 956                      www-format-char-img-style)
 957              t 'literal))
 958
 959           (goto-char (point-min))
 960           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 961             (setq plane (string-to-int (match-string 1))
 962                   code (string-to-int (match-string 2) 16))
 963             (replace-match
 964              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
 965 style=\"%s\">"
 966                      plane code
 967                      chise-wiki-bitmap-glyphs-url
 968                      plane
 969                      (- (lsh code -8) 32)
 970                      (- (logand code 255) 32)
 971                      www-format-char-img-style)
 972              t 'literal))
 973
 974           (goto-char (point-min))
 975           (while (re-search-forward "&\\(R-\\)?C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 976             (setq plane (string-to-int (match-string 2))
 977                   code (string-to-int (match-string 3) 16))
 978             (replace-match
 979              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
 980 style=\"%s\">"
 981                      plane code
 982                      chise-wiki-bitmap-glyphs-url
 983                      plane code
 984                      www-format-char-img-style)
 985              t 'literal))
 986
 987           (goto-char (point-min))
 988           (while (re-search-forward "&\\(R-\\)?JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 989             (setq code (string-to-int (match-string 2) 16))
 990             (replace-match
 991              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 992                      code code)
 993              t 'literal))
 994
 995           (goto-char (point-min))
 996           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 997             (setq code (string-to-int (match-string 2)))
 998             (replace-match
 999              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
1000 style=\"vertical-align:middle\">"
1001                      code
1002                      chise-wiki-bitmap-glyphs-url
1003                      code
1004                      www-format-char-img-style)
1005              t 'literal))
1006
1007           (goto-char (point-min))
1008           (while (re-search-forward "&HNG\\([0-9]+\\)-\\([0-9][0-9][0-9][0-9]\\)\\([0-9]\\);" nil t)
1009             (setq plane (match-string 1)
1010                   code (string-to-int (match-string 2))
1011                   subcode (string-to-int (match-string 3)))
1012             (setq subcode
1013                   (if (eq subcode 0)
1014                       ""
1015                     (char-to-string (decode-char 'ascii (+ 96 subcode)))))
1016             (replace-match
1017              (format
1018               "<div class=\"tooltip\"><img alt=\"HNG%s-%04d%s\" src=\"%s/%s/%04d%s.png\" style=\"
1019 vertical-align:middle; width: 48px; height: 48px\"><span
1020 class=\"tooltiptext\">%s</span></div>"
1021               plane code subcode
1022               chise-wiki-hng-bitmap-glyphs-url
1023               plane code subcode
1024               (charset-description
1025                (car (find (format "HNG%s-" plane)
1026                           coded-charset-entity-reference-alist
1027                           :test (lambda (key cell)
1028                                   (string= key (nth 1 cell))))))
1029               )
1030              t 'literal))
1031
1032           (goto-char (point-min))
1033           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\|R-\\)?AJ1-\\([0-9]+\\);" nil t)
1034             (setq code (string-to-int (match-string 2)))
1035             (replace-match
1036              (format "<img alt=\"AJ1-%05d\" src=\"%s/IVD/AdobeJapan1/CID+%d.png\"
1037 style=\"vertical-align:middle\">"
1038                      code
1039                      chise-wiki-bitmap-glyphs-url
1040                      code
1041                      www-format-char-img-style)
1042              t 'literal))
1043
1044           (goto-char (point-min))
1045           (while (re-search-forward "&\\(A-\\|o-\\|G-\\|g2-\\|R-\\)?MJ\\([0-9]+\\);" nil t)
1046             (setq code (string-to-int (match-string 2)))
1047             (replace-match
1048              (format "<img alt=\"MJ%06d\" src=\"http://mojikiban.ipa.go.jp/search/MJ%06d\"
1049 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1050                      code
1051                      code
1052                      www-format-char-img-style)
1053              t 'literal))
1054
1055           (goto-char (point-min))
1056           (while (re-search-forward "&\\(o-\\|G-\\|g2-\\)?IU[+-]\\([0-9A-F]+\\);" nil t)
1057             (setq code (string-to-int (match-string 2) 16))
1058             (replace-match
1059              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1060 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1061                      code
1062                      code
1063                      www-format-char-img-style)
1064              t 'literal))
1065
1066           (goto-char (point-min))
1067           (while (re-search-forward "&A-\\(comp\\|cgn\\)U[+-]\\([0-9A-F]+\\);" nil t)
1068             (setq code (string-to-int (match-string 2) 16))
1069             (replace-match
1070              (format "<img alt=\"u%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1071 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1072                      code
1073                      code
1074                      www-format-char-img-style)
1075              t 'literal))
1076
1077           (goto-char (point-min))
1078           (while (re-search-forward
1079                   "&\\(A-\\|g2-\\)?U-i\\([0-9]+\\)\\+\\([0-9A-F]+\\);"
1080                   nil t)
1081             (setq plane (string-to-int (match-string 2))
1082                   code (string-to-int (match-string 3) 16))
1083             (replace-match
1084              (format "<img alt=\"u%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-itaiji-%03d.100px.png\"
1085 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1086                      code
1087                      plane
1088                      code
1089                      plane
1090                      www-format-char-img-style)
1091              t 'literal))
1092
1093           (goto-char (point-min))
1094           (while (re-search-forward "&A-IWDSU\\+\\([0-9A-F]+\\);" nil t)
1095             (setq code (string-to-int (match-string 1) 16))
1096             (replace-match
1097              (format "<img alt=\"A-IWDSU+%04x\" src=\"http://glyphwiki.org/glyph/u%04x.100px.png\"
1098 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1099                      code
1100                      code
1101                      www-format-char-img-style)
1102              t 'literal))
1103
1104           (goto-char (point-min))
1105           (while (re-search-forward
1106                   "&\\(A-\\)?CDP-i\\([0-9]+\\)-\\([0-9A-F]+\\);"
1107                   nil t)
1108             (setq plane (string-to-int (match-string 2))
1109                   code (string-to-int (match-string 3) 16))
1110             (replace-match
1111              (format "<img alt=\"cdp-%04x-itaiji-%03d\" src=\"http://glyphwiki.org/glyph/cdp-%04x-itaiji-%03d.100px.png\"
1112 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1113                      code
1114                      plane
1115                      code
1116                      plane
1117                      www-format-char-img-style)
1118              t 'literal))
1119
1120           (goto-char (point-min))
1121           (while (re-search-forward "&\\(g2-\\)?U-v\\([0-9]+\\)\\+\\([0-9A-F]+\\);" nil t)
1122             (setq plane (string-to-int (match-string 2))
1123                   code (string-to-int (match-string 3) 16))
1124             (replace-match
1125              (format "<img alt=\"u%04x-var-%03d\" src=\"http://glyphwiki.org/glyph/u%04x-var-%03d.100px.png\"
1126 style=\"vertical-align:middle; width: 48px; height: 48px\">"
1127                      code
1128                      plane
1129                      code
1130                      plane
1131                      www-format-char-img-style)
1132              t 'literal))
1133
1134           (goto-char (point-min))
1135           (while (re-search-forward "&\\(A-\\|G-\\|R-\\|g2-\\)?GT-\\([0-9]+\\);" nil t)
1136             (setq code (string-to-int (match-string 2)))
1137             (replace-match
1138              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
1139 style=\"%s\">"
1140                      code
1141                      chise-wiki-glyph-cgi-url
1142                      code
1143                      www-format-char-img-style)
1144              t 'literal))
1145
1146           (goto-char (point-min))
1147           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\)?GT-K\\([0-9]+\\);" nil t)
1148             (setq code (string-to-int (match-string 2)))
1149             (replace-match
1150              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
1151 style=\"%s\">"
1152                      code
1153                      chise-wiki-glyph-cgi-url
1154                      code
1155                      www-format-char-img-style)
1156              t 'literal))
1157
1158           (goto-char (point-min))
1159           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
1160             (setq code (string-to-int (match-string 1) 16))
1161             (replace-match
1162              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
1163 style=\"%s\">"
1164                      code
1165                      chise-wiki-glyph-cgi-url
1166                      code
1167                      www-format-char-img-style)
1168              t 'literal))
1169
1170           (goto-char (point-min))
1171           (while (re-search-forward
1172                   "&\\(A-\\|G-\\|g2-\\|R-\\)?CDP-\\([0-9A-F]+\\);" nil t)
1173             (setq code (string-to-int (match-string 2) 16))
1174             (replace-match
1175              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
1176 style=\"%s\">"
1177                      code
1178                      chise-wiki-glyph-cgi-url
1179                      code
1180                      www-format-char-img-style)
1181              t 'literal))
1182
1183           (goto-char (point-min))
1184           (while (re-search-forward
1185                   "&\\(I-\\)?HZK\\(0[1-9]\\|1[0-2]\\)-\\([0-9A-F]+\\);" nil t)
1186             (setq plane (match-string 2)
1187                   code (string-to-int (match-string 3) 16))
1188             (replace-match
1189              (format "<img alt=\"HZK%s-%04X\" src=\"%s?char=HZK%s-%04X\"
1190 style=\"%s\">"
1191                      plane
1192                      code
1193                      chise-wiki-glyph-cgi-url
1194                      plane
1195                      code
1196                      www-format-char-img-style)
1197              t 'literal))
1198
1199           (goto-char (point-min))
1200           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?RUI6-\\([0-9A-F]+\\);" nil t)
1201             (setq code (string-to-int (match-string 2) 16))
1202             (replace-match
1203              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
1204 style=\"vertical-align:middle\">"
1205                      code
1206                      chise-wiki-glyph-cgi-url
1207                      code
1208                      www-format-char-img-style)
1209              t 'literal))
1210
1211           (goto-char (point-min))
1212           (while (re-search-forward "&hanaJU\\+\\([0-9A-F]+\\);" nil t)
1213             (setq code (string-to-int (match-string 1) 16))
1214             (replace-match
1215              (format "<img alt=\"hanaJU+%04X\" src=\"%s?char=hana-JU+%04X\"
1216 style=\"vertical-align:middle\">"
1217                      code
1218                      chise-wiki-glyph-cgi-url
1219                      code
1220                      www-format-char-img-style)
1221              t 'literal))
1222
1223           (goto-char (point-min))
1224           (while (re-search-forward "&\\(A-\\|G-\\|g2-\\|R-\\)?\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
1225             (setq code (string-to-int (match-string 3) 16))
1226             (replace-match
1227              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
1228 style=\"vertical-align:middle\">"
1229                      code
1230                      code
1231                      www-format-char-img-style)
1232              t 'literal))
1233
1234           (goto-char (point-min))
1235           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
1236             (setq code (string-to-int (match-string 1) 16))
1237             (setq start (match-beginning 0)
1238                   end (match-end 0))
1239             (setq char (decode-char 'system-char-id code))
1240             (cond
1241              ((and (setq variants
1242                          (or (www-get-feature-value char '->subsumptive)
1243                              (www-get-feature-value char '->denotational)))
1244                    (progn
1245                      (if (characterp variants)
1246                          (setq variants (list variants)))
1247                      (while (and variants
1248                                  (setq ret (www-format-encode-string
1249                                             (char-to-string (car variants))))
1250                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
1251                        (setq variants (cdr variants)))
1252                      ret))
1253               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
1254                 (goto-char start)
1255                 (delete-region start end)
1256                 (insert ret))
1257               )
1258              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
1259                             (www-get-feature-value char 'ideographic-structure)))
1260               (setq ret
1261                     (mapconcat
1262                      (lambda (ch)
1263                        (if (listp ch)
1264                            (if (characterp (setq rret (find-char ch)))
1265                                (setq ch rret)))
1266                        (if (characterp ch)
1267                            (www-format-encode-string
1268                             (char-to-string ch) without-tags)
1269                          (www-format-encode-string
1270                           (format "%S" ch) without-tags)))
1271                      ret ""))
1272               (when ret
1273                 (goto-char start)
1274                 (delete-region start end)
1275                 (insert ret))
1276               )))
1277           ))
1278       ;; (goto-char (point-min))
1279       ;; (while (search-forward "&GT-" nil t)
1280       ;;   (replace-match "&amp;GT-" t 'literal))
1281       (buffer-string))))
1282
1283 (defun www-html-display-text (text)
1284   (princ
1285    (with-temp-buffer
1286      (insert text)
1287      (goto-char (point-min))
1288      (while (search-forward "<" nil t)
1289        (replace-match "&lt;" nil t))
1290      (goto-char (point-min))
1291      (while (search-forward ">" nil t)
1292        (replace-match "&gt;" nil t))
1293      (goto-char (point-min))
1294      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
1295        (replace-match
1296         (format "<a href=\"%s\">%s</a>"
1297                 (match-string 2)
1298                 (match-string 1))
1299         nil t))
1300      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
1301      (goto-char (point-min))
1302      (while (search-forward "&GT-" nil t)
1303        (replace-match "&amp;GT-" nil t))
1304      (buffer-string))))
1305
1306 (defun www-html-display-paragraph (text)
1307   (princ "<p>")
1308   (www-html-display-text text)
1309   (princ "</p>\n"))
1310
1311
1312 ;;; @ for GlyphWiki
1313 ;;;
1314
1315 (defvar coded-charset-GlyphWiki-id-alist
1316   '((===adobe-japan1-0  "aj1-"  5 d nil)
1317     (===adobe-japan1-1  "aj1-"  5 d nil)
1318     (===adobe-japan1-2  "aj1-"  5 d nil)
1319     (===adobe-japan1-3  "aj1-"  5 d nil)
1320     (===adobe-japan1-4  "aj1-"  5 d nil)
1321     (===adobe-japan1-5  "aj1-"  5 d nil)
1322     (===adobe-japan1-6  "aj1-"  5 d nil)
1323     (===ucs@jis         "u"     4 x nil)
1324     (===daikanwa        "dkw-"  5 d nil)
1325     (===ucs@ks          "u"     4 x "-k")
1326     (==ucs-itaiji-005   "u"     4 x "-itaiji-005")
1327     (=ucs-var-001       "u"     4 x "-var-001")
1328     (=ucs-var-002       "u"     4 x "-var-002")
1329     (=ucs-var-003       "u"     4 x "-var-003")
1330     (=ucs-var-004       "u"     4 x "-var-004")
1331     (=ucs-itaiji-001    "u"     4 x "-itaiji-001")
1332     (=ucs-itaiji-002    "u"     4 x "-itaiji-002")
1333     (=ucs-itaiji-003    "u"     4 x "-itaiji-003")
1334     (=ucs-itaiji-084    "u"     4 x "-itaiji-084")
1335     (=>ucs-itaiji-001   "u"     4 x "-itaiji-001")
1336     (=>ucs-itaiji-006   "u"     4 x "-itaiji-006")
1337     (==adobe-japan1-0   "aj1-"  5 d nil)
1338     (==adobe-japan1-1   "aj1-"  5 d nil)
1339     (==adobe-japan1-2   "aj1-"  5 d nil)
1340     (==adobe-japan1-3   "aj1-"  5 d nil)
1341     (==adobe-japan1-4   "aj1-"  5 d nil)
1342     (==adobe-japan1-5   "aj1-"  5 d nil)
1343     (==adobe-japan1-6   "aj1-"  5 d nil)
1344     (==ucs@jis          "u"     4 x nil)
1345     (==ucs@iso          "u"     4 x nil)
1346     (==ucs@cns          "u"     4 x "-t")
1347     (==ucs@unicode      "u"     4 x "-us")
1348     (==daikanwa         "dkw-"  5 d nil)
1349     (==ucs@ks           "u"     4 x "-k")
1350     (==jis-x0208@1978   "j78-"  4 x nil)
1351     (==jis-x0208        "j90-"  4 x nil)
1352     (==jis-x0208@1990   "j90-"  4 x nil)
1353     (==jis-x0208@1983   "j83-"  4 x nil)
1354     (==cbeta           "cbeta-" 5 d nil)
1355     (=>>hanyo-denshi/ks "koseki-" 6 d nil)
1356     (=>>jis-x0208@1978  "j78-"  4 x nil)
1357     (=>>big5-cdp        "cdp-"  4 x nil)
1358     (=>>adobe-japan1-0  "aj1-"  5 d nil)
1359     (=>>adobe-japan1-1  "aj1-"  5 d nil)
1360     (=>>adobe-japan1-2  "aj1-"  5 d nil)
1361     (=>>adobe-japan1-3  "aj1-"  5 d nil)
1362     (=>>adobe-japan1-4  "aj1-"  5 d nil)
1363     (=>>adobe-japan1-5  "aj1-"  5 d nil)
1364     (=>>adobe-japan1-6  "aj1-"  5 d nil)
1365     (=>>jis-x0208       "j90-"  4 x nil)
1366     (=>>jis-x0208@1990  "j90-"  4 x nil)
1367     (=>>jis-x0208@1983  "j83-"  4 x nil)
1368     (=>>daikanwa        "dkw-"  5 d nil)
1369     (=adobe-japan1-0    "aj1-"  5 d nil)
1370     (=adobe-japan1-1    "aj1-"  5 d nil)
1371     (=adobe-japan1-2    "aj1-"  5 d nil)
1372     (=adobe-japan1-3    "aj1-"  5 d nil)
1373     (=adobe-japan1-4    "aj1-"  5 d nil)
1374     (=adobe-japan1-5    "aj1-"  5 d nil)
1375     (=adobe-japan1-6    "aj1-"  5 d nil)
1376     (=decomposition@cid)
1377     (=decomposition@hanyo-denshi)
1378     (=hanyo-denshi/ks   "koseki-" 6 d nil)
1379     (=koseki            "koseki-" 6 d nil)
1380     (=ucs@jis           "u"     4 x nil)
1381     (=ucs@cns           "u"     4 x "-t")
1382     (=ucs@ks            "u"     4 x "-k")
1383     (=ucs@JP            "u"     4 x nil)
1384     (=ucs@gb            "u"     4 x "-g")
1385     (=ucs@iso           "u"     4 x "-u")
1386     (=ucs@unicode       "u"     4 x "-us")
1387     (=big5-cdp          "cdp-"  4 x nil)
1388     (=>big5-cdp         "cdp-"  4 x nil)
1389     (=cbeta            "cbeta-" 5 d nil)
1390     (=big5-cdp-var-3    "cdp-"  4 x "-var-3")
1391     (=big5-cdp-var-5    "cdp-"  4 x "-var-5")
1392     (=big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1393     (=big5-cdp-itaiji-002 "cdp-" 4 x "-itaiji-002")
1394     (=>big5-cdp-itaiji-001 "cdp-" 4 x "-itaiji-001")
1395     (=jef-china3        "jc3-"  4 x nil)
1396     (=jis-x0212         "jsp-"  4 x nil)
1397     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
1398     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
1399     (=jis-x0213-2       "jx2-"  4 x nil)
1400     (=gt-k              "gt-k"  5 d nil)
1401     (=jis-x0208@1978/1pr "j78-" 4 x nil)
1402     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
1403     (=jis-x0208@1978    "j78-"  4 x nil)
1404     (=+>jis-x0208@1978  "j78-"  4 x nil)
1405     (=+>jis-x0208       "j90-"  4 x nil)
1406     (=+>jis-x0208@1990  "j90-"  4 x nil)
1407     (=+>jis-x0208@1983  "j83-"  4 x nil)
1408     (=ucs               "u"     4 x nil)
1409     (=big5              "b-"    4 x nil)
1410     (=daikanwa          "dkw-"  5 d nil)
1411     (=gt                "gt-"   5 d nil)
1412     (=ruimoku-v6        "rui6-" 4 x nil)
1413     (=>ruimoku-v6       "rui6-" 4 x nil)
1414     (=ks-x1001          "k0-"   4 x nil)
1415     (=cns11643-1        "c1-"   4 x nil)
1416     (=cns11643-2        "c2-"   4 x nil)
1417     (=cns11643-3        "c3-"   4 x nil)
1418     (=cns11643-4        "c4-"   4 x nil)
1419     (=cns11643-5        "c5-"   4 x nil)
1420     (=cns11643-6        "c6-"   4 x nil)
1421     (=cns11643-7        "c7-"   4 x nil)
1422     (=jis-x0208         "j90-"  4 x nil)
1423     (=jis-x0208@1990    "j90-"  4 x nil)
1424     (=jis-x0208@1983    "j83-"  4 x nil)
1425     ))
1426
1427 (defun char-GlyphWiki-id (char)
1428   (let ((rest coded-charset-GlyphWiki-id-alist)
1429         spec ret code)
1430     (while (and rest
1431                 (setq spec (pop rest))
1432                 (null (setq ret (char-feature char (car spec))))))
1433     (when ret
1434       (or
1435        (and (listp ret)
1436             (mapconcat #'char-GlyphWiki-id ret "-"))
1437        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
1438             (cond
1439              ((and (or (encode-char char '=jis-x0208@1990)
1440                        (encode-char char '=jis-x0212)
1441                        (encode-char char '=jis-x0213-1)
1442                        (encode-char char '=jis-x0213-2))
1443                    (setq code (encode-char char '=ucs@jis)))
1444               (format "u%04x" code)
1445               )
1446              ((and (or (encode-char char '=gb2312)
1447                        (encode-char char '=gb12345))
1448                    (setq code (encode-char char '=ucs@gb)))
1449               (format "u%04x-g" code)
1450               )
1451              ((and (or (encode-char char '=cns11643-1)
1452                        (encode-char char '=cns11643-2)
1453                        (encode-char char '=cns11643-3)
1454                        (encode-char char '=cns11643-4)
1455                        (encode-char char '=cns11643-5)
1456                        (encode-char char '=cns11643-6)
1457                        (encode-char char '=cns11643-7))
1458                    (setq code (encode-char char '=ucs@cns)))
1459               (format "u%04x-t" code)
1460               )
1461              ((and (encode-char char '=ks-x1001)
1462                    (setq code (encode-char char '=ucs@ks)))
1463               (format "u%04x-k" code)
1464               )))
1465        (format (format "%s%%0%d%s%s"
1466                        (nth 1 spec)
1467                        (nth 2 spec)
1468                        (nth 3 spec)
1469                        (or (nth 4 spec) ""))
1470                ret)))))
1471
1472
1473 ;;; @ End.
1474 ;;;
1475
1476 (provide 'cwiki-common)
1477
1478 ;;; cwiki-common.el ends here