cwiki-common.el

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