cwiki-common.el

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