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