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