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