cwiki-common.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'char-db-util)
   3
   4 (setq file-name-coding-system 'utf-8-mcs-er)
   5
   6
   7 (concord-assign-genre 'creator@ruimoku "/usr/local/var/ruimoku/db")
   8 (concord-assign-genre 'person-name@ruimoku "/usr/local/var/ruimoku/db")
   9
  10 (concord-assign-genre 'journal-volume@ruimoku "/usr/local/var/ruimoku/db")
  11 (concord-assign-genre 'article@ruimoku "/usr/local/var/ruimoku/db")
  12 (concord-assign-genre 'book@ruimoku "/usr/local/var/ruimoku/db")
  13
  14 (concord-assign-genre 'classification@ruimoku "/usr/local/var/ruimoku/db")
  15 (concord-assign-genre 'region@ruimoku "/usr/local/var/ruimoku/db")
  16 (concord-assign-genre 'era@ruimoku "/usr/local/var/ruimoku/db")
  17 (concord-assign-genre 'period@ruimoku "/usr/local/var/ruimoku/db")
  18 (concord-assign-genre 'journal@ruimoku "/usr/local/var/ruimoku/db")
  19
  20
  21 (defvar chise-wiki-view-url "view.cgi")
  22 (defvar chise-wiki-edit-url "edit.cgi")
  23
  24 (defvar chise-wiki-bitmap-glyphs-url
  25   "http://chise.zinbun.kyoto-u.ac.jp/glyphs")
  26
  27 (defvar chise-wiki-glyph-cgi-url
  28   "http://chise.zinbun.kyoto-u.ac.jp/chisewiki/glyph.cgi")
  29
  30 (defvar chise-wiki-displayed-features nil)
  31
  32 (defun decode-uri-string (string &optional coding-system)
  33   (if (> (length string) 0)
  34       (let ((i 0)
  35             dest)
  36         (setq string
  37               (mapconcat (lambda (char)
  38                            (if (eq char ?+)
  39                                " "
  40                              (char-to-string char)))
  41                          string ""))
  42         (while (string-match "%\\([0-9A-F][0-9A-F]\\)" string i)
  43           (setq dest (concat dest
  44                              (substring string i (match-beginning 0))
  45                              (char-to-string
  46                               (int-char
  47                                (string-to-int (match-string 1 string) 16))))
  48                 i (match-end 0)))
  49         (decode-coding-string
  50          (concat dest (substring string i))
  51          coding-system))))
  52
  53 (defun www-feature-type (feature-name)
  54   (or (char-feature-property feature-name 'type)
  55       (let ((str (symbol-name feature-name)))
  56         (cond
  57          ((string-match "\\*note\\(@[^*]+\\)?$" str)
  58           'stext)
  59          ((string-match "\\*sources\\(@[^*]+\\)?$" str)
  60           'domain-list)
  61          ((string-match "\\*" str)
  62           nil)
  63          ((string-match "^\\(->\\|<-\\)" str)
  64           'relation)
  65          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
  66           'structure)
  67          ))))
  68
  69 (defun www-feature-format (feature-name)
  70   (or (char-feature-property feature-name 'format)
  71       (let (fn parent ret)
  72         (setq fn feature-name)
  73         (while (and (setq parent (char-feature-name-parent fn))
  74                     (null (setq ret
  75                                 (char-feature-property
  76                                  parent 'format))))
  77           (setq fn parent))
  78         ret)
  79       '((name) " : " (value))))
  80
  81 (defun www-feature-value-format (feature-name)
  82   (or (char-feature-property feature-name 'value-format)
  83       (let (fn parent ret)
  84         (setq fn feature-name)
  85         (while (and (setq parent (char-feature-name-parent fn))
  86                     (null (setq ret
  87                                 (char-feature-property
  88                                  parent 'value-format))))
  89           (setq fn parent))
  90         ret)
  91       (let ((type (www-feature-type feature-name)))
  92         (cond ((eq type 'relation)
  93                'space-separated-char-list)
  94               ((eq type 'structure)
  95                'space-separated-ids)
  96               ((eq type 'stext)
  97                'wiki-text)
  98               ))
  99       (if (find-charset feature-name)
 100           (if (and (= (charset-dimension feature-name) 2)
 101                    (= (charset-chars feature-name) 94))
 102               '("0x" (HEX)
 103                 " (" (decimal) ") <" (ku-ten) "> " (prev-char) (next-char))
 104             '("0x" (HEX) " (" (decimal) ") " (prev-char) (next-char))))))
 105
 106 (defun char-feature-name-at-domain (feature-name domain)
 107   (if domain
 108       (let ((name (symbol-name feature-name)))
 109         (cond
 110          ((string-match "@[^*]+$" name)
 111           (intern (format "%s/%s" name domain))
 112           )
 113          (t
 114           (intern (format "%s@%s" name domain))
 115           )))
 116     feature-name))
 117
 118 (defun char-feature-name-parent (feature-name)
 119   (let ((name (symbol-name feature-name)))
 120     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 121         (intern (substring name 0 (car (last (match-data) 2)))))))
 122
 123 (defun char-feature-name-domain (feature-name)
 124   (let ((name (symbol-name feature-name)))
 125     (if (string-match "@[^@/*]+\\(/[^@/*]+\\)*$" name)
 126         (intern (substring name (1+ (match-beginning 0)))))))
 127
 128 (defun char-feature-name-sans-versions (feature)
 129   (let ((feature-name (symbol-name feature)))
 130     (if (string-match "[@/]\\$rev=latest$" feature-name)
 131         (intern (substring feature-name 0 (match-beginning 0)))
 132       feature)))
 133
 134 (defun est-object-genre (object)
 135   (if (characterp object)
 136       'character
 137     (concord-object-genre object)))
 138
 139 (defun www-get-feature-value (object feature)
 140   (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
 141     (cond
 142      ((characterp object)
 143       (mount-char-attribute-table latest-feature)
 144       (or (char-feature object latest-feature)
 145           (char-feature object feature))
 146       )
 147      (t
 148       (or (condition-case nil
 149               (concord-object-get object latest-feature)
 150             (error nil))
 151           (condition-case nil
 152               (concord-object-get object feature)
 153             (error nil)))
 154       ))))
 155
 156 (defun get-previous-code-point (ccs code)
 157   (let ((chars (charset-chars ccs))
 158         (dim (charset-dimension ccs))
 159         (i 0)
 160         mask byte-min byte-max
 161         bytes dest)
 162     (cond
 163      ((= chars 94)
 164       (setq mask #x7F
 165             byte-min 33
 166             byte-max 126)
 167       )
 168      ((= chars 96)
 169       (setq mask #x7F
 170             byte-min 32
 171             byte-max 127)
 172       )
 173      ((= chars 128)
 174       (setq mask #x7F
 175             byte-min 0
 176             byte-max #xFF)
 177       )
 178      (t ; (= chars 256)
 179       (setq mask #xFF
 180             byte-min 0
 181             byte-max #xFF)
 182       ))
 183     (setq bytes (make-vector dim 0))
 184     (while (< i dim)
 185       (aset bytes i (logand (lsh code (* i -8)) mask))
 186       (setq i (1+ i)))
 187     (setq i 0)
 188     (while (and (< i dim)
 189                 (progn
 190                   (aset bytes i (1- (aref bytes i)))
 191                   (< (aref bytes i) byte-min)))
 192       (aset bytes i byte-max)
 193       (setq i (1+ i)))
 194     (when (< i dim)
 195       (setq dest (aref bytes 0)
 196             i 1)
 197       (while (< i dim)
 198         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 199               i (1+ i)))
 200       dest)))
 201
 202 (defun get-next-code-point (ccs code)
 203   (let ((chars (charset-chars ccs))
 204         (dim (charset-dimension ccs))
 205         (i 0)
 206         mask byte-min byte-max
 207         bytes dest)
 208     (cond
 209      ((= chars 94)
 210       (setq mask #x7F
 211             byte-min 33
 212             byte-max 126)
 213       )
 214      ((= chars 96)
 215       (setq mask #x7F
 216             byte-min 32
 217             byte-max 127)
 218       )
 219      ((= chars 128)
 220       (setq mask #x7F
 221             byte-min 0
 222             byte-max #xFF)
 223       )
 224      (t ; (= chars 256)
 225       (setq mask #xFF
 226             byte-min 0
 227             byte-max #xFF)
 228       ))
 229     (setq bytes (make-vector dim 0))
 230     (while (< i dim)
 231       (aset bytes i (logand (lsh code (* i -8)) mask))
 232       (setq i (1+ i)))
 233     (setq i 0)
 234     (while (and (< i dim)
 235                 (progn
 236                   (aset bytes i (1+ (aref bytes i)))
 237                   (> (aref bytes i) byte-max)))
 238       (aset bytes i byte-min)
 239       (setq i (1+ i)))
 240     (when (< i dim)
 241       (setq dest (aref bytes 0)
 242             i 1)
 243       (while (< i dim)
 244         (setq dest (logior dest (lsh (aref bytes i) (* i 8)))
 245               i (1+ i)))
 246       dest)))
 247
 248 (defun find-previous-defined-code-point (ccs code)
 249   (let ((i (get-previous-code-point ccs code))
 250         char)
 251     (cond
 252      ((eq ccs '=jis-x0208)
 253       (setq ccs '=jis-x0208@1990))
 254      ((eq ccs '=jis-x0213-1)
 255       (setq ccs '=jis-x0213-1@2004)))
 256     (while (and i
 257                 (>= i 0)
 258                 (null (setq char (decode-char ccs i
 259                                               (unless (eq ccs '=ucs)
 260                                                 'defined-only)))))
 261       (setq i (get-previous-code-point ccs i)))
 262     char))
 263
 264 (defun find-next-defined-code-point (ccs code)
 265   (let ((i (get-next-code-point ccs code))
 266         max char)
 267     (setq max (+ code 1000))
 268     (cond
 269      ((eq ccs '=jis-x0208)
 270       (setq ccs '=jis-x0208@1990))
 271      ((eq ccs '=jis-x0213-1)
 272       (setq ccs '=jis-x0213-1@2004)))
 273     (while (and i
 274                 (<= i max)
 275                 (null (setq char (decode-char ccs i
 276                                               (unless (eq ccs '=ucs)
 277                                                 'defined-only)))))
 278       (setq i (get-next-code-point ccs i)))
 279     char))
 280
 281
 282 ;;; @ URI representation
 283 ;;;
 284
 285 (defun www-uri-decode-feature-name (uri-feature)
 286   (let (feature)
 287     (cond
 288      ((string-match "^from\\." uri-feature)
 289       (intern (format "<-%s" (substring uri-feature (match-end 0))))
 290       )
 291      ((string-match "^to\\." uri-feature)
 292       (intern (format "->%s" (substring uri-feature (match-end 0))))
 293       )
 294      ((string-match "^rep\\." uri-feature)
 295       (intern (format "=%s" (substring uri-feature (match-end 0))))
 296       )
 297      ((string-match "^g\\." uri-feature)
 298       (intern (format "=>>%s" (substring uri-feature (match-end 0))))
 299       )
 300      ((string-match "^gi\\." uri-feature)
 301       (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
 302       )
 303      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
 304       (intern (format "=>>%s%s"
 305                       (make-string (string-to-int
 306                                     (match-string 1 uri-feature))
 307                                    ?>)
 308                       (substring uri-feature (match-end 0))))
 309       )
 310      ((string-match "^a\\." uri-feature)
 311       (intern (format "=>%s" (substring uri-feature (match-end 0))))
 312       )
 313      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 314       (intern (format "%s>%s"
 315                       (make-string (string-to-int
 316                                     (match-string 1 uri-feature))
 317                                    ?=)
 318                       (substring uri-feature (match-end 0))))
 319       )
 320      ((and (setq feature (intern (format "=>%s" uri-feature)))
 321            (find-charset feature))
 322       feature)
 323      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 324            (find-charset feature))
 325       feature)
 326      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 327            (find-charset feature))
 328       feature)
 329      ((and (setq feature (intern (format "=%s" uri-feature)))
 330            (find-charset feature))
 331       feature)
 332      (t (intern uri-feature)))))
 333
 334 (defun www-uri-encode-feature-name (feature-name)
 335   (setq feature-name (symbol-name feature-name))
 336   (cond
 337    ((string-match "^=\\([^=>]+\\)" feature-name)
 338     (concat "rep." (substring feature-name (match-beginning 1)))
 339     )
 340    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 341     (concat "g." (substring feature-name (match-beginning 1)))
 342     )
 343    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 344     (concat "gi." (substring feature-name (match-beginning 1)))
 345     )
 346    ((string-match "^=>>\\(>+\\)" feature-name)
 347     (format "gi%d.%s"
 348             (length (match-string 1 feature-name))
 349             (substring feature-name (match-end 1)))
 350     )
 351    ((string-match "^=>\\([^=>]+\\)" feature-name)
 352     (concat "a." (substring feature-name (match-beginning 1)))
 353     )
 354    ((string-match "^\\(=+\\)>" feature-name)
 355     (format "a%d.%s"
 356             (length (match-string 1 feature-name))
 357             (substring feature-name (match-end 0)))
 358     )
 359    ((string-match "^->" feature-name)
 360     (concat "to." (substring feature-name (match-end 0)))
 361     )
 362    ((string-match "^<-" feature-name)
 363     (concat "from." (substring feature-name (match-end 0)))
 364     )
 365    (t feature-name)))
 366
 367 (defun www-uri-make-feature-name-url (uri-feature-name uri-char)
 368   (format "%s?feature=%s&char=%s"
 369           chise-wiki-view-url uri-feature-name uri-char))
 370
 371 (defun www-uri-decode-object (genre char-rep)
 372   (let (ccs cpos)
 373     (cond
 374      ((string-match "\\(%3A\\|:\\)" char-rep)
 375       (setq ccs (substring char-rep 0 (match-beginning 0))
 376             cpos (substring char-rep (match-end 0)))
 377       (setq ccs (www-uri-decode-feature-name ccs))
 378       (cond
 379        ((string-match "^0x" cpos)
 380         (setq cpos
 381               (string-to-number (substring cpos (match-end 0)) 16))
 382         )
 383        (t
 384         (setq cpos (car (read-from-string cpos)))
 385         ))
 386       (if (and (eq genre 'character)
 387                (numberp cpos))
 388           (decode-char ccs cpos)
 389         (concord-decode-object ccs cpos genre))
 390       )
 391      (t
 392       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 393       (cond
 394        ((eq genre 'character)
 395         (when (= (length char-rep) 1)
 396           (aref char-rep 0))
 397         )
 398        ((eq genre 'feature)
 399         (concord-decode-object
 400          '=id (www-uri-decode-feature-name char-rep) 'feature)
 401         )
 402        (t
 403         (concord-decode-object
 404          '=id (car (read-from-string char-rep)) genre)
 405         ))))))
 406
 407 (defun www-uri-encode-object (object)
 408   (if (characterp object)
 409       (if (encode-char object '=ucs)
 410           (mapconcat
 411            (lambda (byte)
 412              (format "%%%02X" byte))
 413            (encode-coding-string (char-to-string object) 'utf-8-mcs-er)
 414            "")
 415         (let ((ccs-list '(; =ucs
 416                           =cns11643-1 =cns11643-2 =cns11643-3
 417                           =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
 418                           =gb2312 =gb12345
 419                           =jis-x0208 =jis-x0208@1990
 420                           =jis-x0212
 421                           =cbeta =jef-china3
 422                           =jis-x0213-1@2000 =jis-x0213-1@2004
 423                           =jis-x0208@1983 =jis-x0208@1978
 424                           =zinbun-oracle =>zinbun-oracle
 425                           =daikanwa
 426                           =gt =gt-k
 427                           =>>jis-x0208 =>>jis-x0213-1
 428                           =>jis-x0208 =>jis-x0213-1
 429                           =>>gt
 430                           =ruimoku-v6
 431                           =big5
 432                           =big5-cdp))
 433               ccs ret)
 434           (while (and ccs-list
 435                       (setq ccs (pop ccs-list))
 436                       (not (setq ret (encode-char object ccs 'defined-only)))))
 437           (cond (ret
 438                  (format "%s:0x%X"
 439                          (www-uri-encode-feature-name ccs)
 440                          ret))
 441                 ((and (setq ccs (car (split-char object)))
 442                       (setq ret (encode-char object ccs)))
 443                  (format "%s:0x%X"
 444                          (www-uri-encode-feature-name ccs)
 445                          ret))
 446                 (t
 447                  (format "system-char-id:0x%X"
 448                          (encode-char object 'system-char-id))
 449                  ))))
 450     (format "rep.id:%s" (concord-object-id object))))
 451
 452 (defun est-format-object (object)
 453   (if (characterp object)
 454       (char-to-string object)
 455     (format "%s" (concord-object-id object))))
 456
 457
 458 ;;; @ Feature name presentation
 459 ;;;
 460
 461 (defun www-format-feature-name-default (feature-name)
 462   (mapconcat
 463    #'capitalize
 464    (split-string
 465     (symbol-name feature-name)
 466     "-")
 467    " "))
 468
 469 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 470   (let ((str (symbol-name feature-name))
 471         base meta)
 472     (cond
 473      ((string-match "\\*[^*]+$" str)
 474       (setq base (substring str 0 (match-beginning 0))
 475             meta (substring str (match-beginning 0)))
 476       (concat (www-format-feature-name* (intern base) lang)
 477               meta))
 478      (t
 479       (www-format-feature-name-default feature-name)
 480       ))))
 481
 482 (defun www-format-feature-name-as-rel-to (feature-name)
 483   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 484
 485 (defun www-format-feature-name-as-rel-from (feature-name)
 486   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 487
 488 (defun www-format-feature-name-as-CCS (feature-name)
 489   (let* ((rest
 490           (split-string
 491            (symbol-name feature-name)
 492            "-"))
 493          (dest (upcase (pop rest))))
 494     (when (string-match "^=+>*" dest)
 495       (setq dest (concat (substring dest 0 (match-end 0))
 496                          " "
 497                          (substring dest (match-end 0)))))
 498     (cond
 499      (rest
 500       (while (cdr rest)
 501         (setq dest (concat dest " " (upcase (pop rest)))))
 502       (if (string-match "^[0-9]+$" (car rest))
 503           (concat dest "-" (car rest))
 504         (concat dest " " (upcase (car rest))))
 505       )
 506      (t dest))))
 507
 508 (defun www-format-feature-name* (feature-name &optional lang)
 509   (let (name fn parent ret)
 510     (cond
 511      ((or (and lang
 512                (char-feature-property
 513                 feature-name
 514                 (intern (format "name@%s" lang))))
 515           (char-feature-property
 516            feature-name 'name)))
 517      ((and (setq name (symbol-name feature-name))
 518            (string-match "\\*" name))
 519       (www-format-feature-name-as-metadata feature-name lang))
 520      (t
 521       (setq fn feature-name)
 522       (while (and (setq parent (char-feature-name-parent fn))
 523                   (null (setq ret
 524                               (or (and lang
 525                                        (char-feature-property
 526                                         parent
 527                                         (intern (format "name@%s" lang))))
 528                                   (char-feature-property
 529                                    parent 'name)))))
 530         (setq fn parent))
 531       (cond
 532        (ret
 533         (concat ret (substring (symbol-name feature-name)
 534                                (length (symbol-name parent)))))
 535        ((find-charset feature-name)
 536         (www-format-feature-name-as-CCS feature-name))
 537        ((string-match "^\\(->\\)" name)
 538         (www-format-feature-name-as-rel-to feature-name))
 539        ((string-match "^\\(<-\\)" name)
 540         (www-format-feature-name-as-rel-from feature-name))
 541        (t
 542         (www-format-feature-name-default feature-name)
 543         ))
 544       ))))
 545
 546 (defun www-format-feature-name (feature-name &optional lang)
 547   (www-format-encode-string
 548    (www-format-feature-name* feature-name lang)))
 549
 550
 551 ;;; @ HTML generator
 552 ;;;
 553
 554 (defun www-format-encode-string (string &optional without-tags)
 555   (with-temp-buffer
 556     (insert string)
 557     (let (plane code start end char variants ret rret)
 558       (goto-char (point-min))
 559       (while (search-forward "<" nil t)
 560         (replace-match "&lt;" nil t))
 561       (goto-char (point-min))
 562       (while (search-forward ">" nil t)
 563         (replace-match "&gt;" nil t))
 564       (if without-tags
 565           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 566         (let ((coded-charset-entity-reference-alist
 567                (list*
 568                 '(=gt                   "GT-" 5 d)
 569                 '(=cns11643-1           "C1-" 4 X)
 570                 '(=cns11643-2           "C2-" 4 X)
 571                 '(=cns11643-3           "C3-" 4 X)
 572                 '(=cns11643-4           "C4-" 4 X)
 573                 '(=cns11643-5           "C5-" 4 X)
 574                 '(=cns11643-6           "C6-" 4 X)
 575                 '(=cns11643-7           "C7-" 4 X)
 576                 '(=gb2312               "G0-" 4 X)
 577                 '(=gb12345              "G1-" 4 X)
 578                 '(=jis-x0208@1990       "J90-" 4 X)
 579                 '(=jis-x0212            "JSP-" 4 X)
 580                 '(=cbeta                "CB" 5 d)
 581                 '(=jis-x0208@1997       "J97-" 4 X)
 582                 '(=jis-x0208@1978       "J78-" 4 X)
 583                 '(=jis-x0208@1983       "J83-" 4 X)
 584                 '(=ruimoku-v6           "RUI6-" 4 X)
 585                 '(=zinbun-oracle        "ZOB-" 4 d)
 586                 '(=jef-china3           "JC3-" 4 X)
 587                 '(=daikanwa             "M-" 5 d)
 588                 coded-charset-entity-reference-alist)))
 589           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 590
 591           (goto-char (point-min))
 592           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 593             (setq code (string-to-int (match-string 1)))
 594             (replace-match
 595              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
 596                      code
 597                      chise-wiki-bitmap-glyphs-url
 598                      (/ code 1000) code)
 599              t 'literal))
 600
 601           (goto-char (point-min))
 602           (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 603             (setq plane (match-string 1)
 604                   code (string-to-int (match-string 2) 16))
 605             (replace-match
 606              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
 607                      plane code
 608                      chise-wiki-bitmap-glyphs-url
 609                      plane
 610                      (- (lsh code -8) 32)
 611                      (- (logand code 255) 32))
 612              t 'literal))
 613
 614           (goto-char (point-min))
 615           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 616             (setq plane (string-to-int (match-string 1))
 617                   code (string-to-int (match-string 2) 16))
 618             (replace-match
 619              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
 620                      plane code
 621                      chise-wiki-bitmap-glyphs-url
 622                      plane
 623                      (- (lsh code -8) 32)
 624                      (- (logand code 255) 32))
 625              t 'literal))
 626
 627           (goto-char (point-min))
 628           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 629             (setq plane (string-to-int (match-string 1))
 630                   code (string-to-int (match-string 2) 16))
 631             (replace-match
 632              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
 633                      plane code
 634                      chise-wiki-bitmap-glyphs-url
 635                      plane code)
 636              t 'literal))
 637
 638           (goto-char (point-min))
 639           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 640             (setq code (string-to-int (match-string 1) 16))
 641             (replace-match
 642              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 643                      code code)
 644              t 'literal))
 645
 646           (goto-char (point-min))
 647           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 648             (setq code (string-to-int (match-string 2)))
 649             (replace-match
 650              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
 651                      code
 652                      chise-wiki-bitmap-glyphs-url
 653                      code)
 654              t 'literal))
 655
 656           (goto-char (point-min))
 657           (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
 658             (setq code (string-to-int (match-string 2)))
 659             (replace-match
 660              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
 661                      code
 662                      chise-wiki-glyph-cgi-url
 663                      code)
 664              t 'literal))
 665
 666           (goto-char (point-min))
 667           (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
 668             (setq code (string-to-int (match-string 2)))
 669             (replace-match
 670              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\">"
 671                      code
 672                      chise-wiki-glyph-cgi-url
 673                      code)
 674              t 'literal))
 675
 676           (goto-char (point-min))
 677           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 678             (setq code (string-to-int (match-string 1) 16))
 679             (replace-match
 680              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
 681                      code
 682                      chise-wiki-glyph-cgi-url
 683                      code)
 684              t 'literal))
 685
 686           (goto-char (point-min))
 687           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 688             (setq code (string-to-int (match-string 1) 16))
 689             (replace-match
 690              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
 691                      code
 692                      chise-wiki-glyph-cgi-url
 693                      code)
 694              t 'literal))
 695
 696           (goto-char (point-min))
 697           (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
 698             (setq code (string-to-int (match-string 1) 16))
 699             (replace-match
 700              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\">"
 701                      code
 702                      chise-wiki-glyph-cgi-url
 703                      code)
 704              t 'literal))
 705
 706           (goto-char (point-min))
 707           (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
 708             (setq code (string-to-int (match-string 2) 16))
 709             (replace-match
 710              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
 711                      code
 712                      code)
 713              t 'literal))
 714
 715           (goto-char (point-min))
 716           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 717             (setq code (string-to-int (match-string 1) 16))
 718             (setq start (match-beginning 0)
 719                   end (match-end 0))
 720             (setq char (decode-char 'system-char-id code))
 721             (cond
 722              ((and (setq variants
 723                          (or (www-get-feature-value char '->subsumptive)
 724                              (www-get-feature-value char '->denotational)))
 725                    (progn
 726                      (while (and variants
 727                                  (setq ret (www-format-encode-string
 728                                             (char-to-string (car variants))))
 729                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 730                        (setq variants (cdr variants)))
 731                      ret))
 732               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 733                 (goto-char start)
 734                 (delete-region start end)
 735                 (insert ret))
 736               )
 737              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
 738                             (www-get-feature-value char 'ideographic-structure)))
 739               (setq ret
 740                     (mapconcat
 741                      (lambda (ch)
 742                        (if (listp ch)
 743                            (if (characterp (setq rret (find-char ch)))
 744                                (setq ch rret)))
 745                        (if (characterp ch)
 746                            (www-format-encode-string
 747                             (char-to-string ch) without-tags)
 748                          (www-format-encode-string
 749                           (format "%S" ch) without-tags)))
 750                      ret ""))
 751               (when ret
 752                 (goto-char start)
 753                 (delete-region start end)
 754                 (insert ret))
 755               )))
 756           ))
 757       ;; (goto-char (point-min))
 758       ;; (while (search-forward "&GT-" nil t)
 759       ;;   (replace-match "&amp;GT-" t 'literal))
 760       (buffer-string))))
 761
 762 (defun www-html-display-text (text)
 763   (princ
 764    (with-temp-buffer
 765      (insert text)
 766      (goto-char (point-min))
 767      (while (search-forward "<" nil t)
 768        (replace-match "&lt;" nil t))
 769      (goto-char (point-min))
 770      (while (search-forward ">" nil t)
 771        (replace-match "&gt;" nil t))
 772      (goto-char (point-min))
 773      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
 774        (replace-match
 775         (format "<a href=\"%s\">%s</a>"
 776                 (match-string 2)
 777                 (match-string 1))
 778         nil t))
 779      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 780      (goto-char (point-min))
 781      (while (search-forward "&GT-" nil t)
 782        (replace-match "&amp;GT-" nil t))
 783      (buffer-string))))
 784
 785 (defun www-html-display-paragraph (text)
 786   (princ "<p>")
 787   (www-html-display-text text)
 788   (princ "</p>\n"))
 789
 790
 791 ;;; @ for GlyphWiki
 792 ;;;
 793
 794 (defvar coded-charset-GlyphWiki-id-alist
 795   '((=ucs               "u"     4 x nil)
 796     (=ucs@JP            "u"     4 x nil)
 797     (=ucs@jis           "u"     4 x nil)
 798     (=ucs@gb            "u"     4 x "-g")
 799     (=ucs@cns           "u"     4 x "-t")
 800     (=ucs@ks            "u"     4 x "-k")
 801     (=ucs@iso           "u"     4 x "-u")
 802     (=ucs@unicode       "u"     4 x "-us")
 803     (=adobe-japan1-6    "aj1-"  5 d nil)
 804     (=gt                "gt-"   5 d nil)
 805     (=big5-cdp          "cdp-"  4 x nil)
 806     (=cbeta             "cb"    5 d nil)
 807     (=jis-x0208@1978/1pr "j78-" 4 x nil)
 808     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
 809     (=jis-x0208@1978    "j78-"  4 x nil)
 810     (=jis-x0208@1983    "j83-"  4 x nil)
 811     (=jis-x0208@1990    "j90-"  4 x nil)
 812     (=jis-x0212         "jsp-"  4 x nil)
 813     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
 814     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
 815     (=jis-x0213-2       "jx2-"  4 x nil)
 816     (=cns11643-1        "c1-"   4 x nil)
 817     (=cns11643-2        "c2-"   4 x nil)
 818     (=cns11643-3        "c3-"   4 x nil)
 819     (=cns11643-4        "c4-"   4 x nil)
 820     (=cns11643-5        "c5-"   4 x nil)
 821     (=cns11643-6        "c6-"   4 x nil)
 822     (=cns11643-7        "c7-"   4 x nil)
 823     (=daikanwa          "dkw-"  5 d nil)
 824     (=gt-k              "gt-k"  5 d nil)
 825     (=jef-china3        "jc3-"  4 x nil)
 826     (=big5              "b-"    4 x nil)
 827     (=ks-x1001          "k0-"   4 x nil)
 828     ))
 829
 830 (defun char-GlyphWiki-id (char)
 831   (let ((rest coded-charset-GlyphWiki-id-alist)
 832         spec ret code)
 833     (while (and rest
 834                 (setq spec (pop rest))
 835                 (null (setq ret (char-feature char (car spec))))))
 836     (when ret
 837       (or
 838        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
 839             (cond
 840              ((and (or (encode-char char '=jis-x0208@1990)
 841                        (encode-char char '=jis-x0212)
 842                        (encode-char char '=jis-x0213-1))
 843                    (setq code (encode-char char '=ucs@jis)))
 844               (format "u%04x" code)
 845               )
 846              ((and (or (encode-char char '=gb2312)
 847                        (encode-char char '=gb12345))
 848                    (setq code (encode-char char '=ucs@gb)))
 849               (format "u%04x-g" code)
 850               )
 851              ((and (or (encode-char char '=cns11643-1)
 852                        (encode-char char '=cns11643-2)
 853                        (encode-char char '=cns11643-3)
 854                        (encode-char char '=cns11643-4)
 855                        (encode-char char '=cns11643-5)
 856                        (encode-char char '=cns11643-6)
 857                        (encode-char char '=cns11643-7))
 858                    (setq code (encode-char char '=ucs@cns)))
 859               (format "u%04x-t" code)
 860               )
 861              ((and (encode-char char '=ks-x1001)
 862                    (setq code (encode-char char '=ucs@ks)))
 863               (format "u%04x-k" code)
 864               )))
 865        (format (format "%s%%0%d%s%s"
 866                        (nth 1 spec)
 867                        (nth 2 spec)
 868                        (nth 3 spec)
 869                        (or (nth 4 spec) ""))
 870                ret)))))
 871
 872
 873 ;;; @ End.
 874 ;;;
 875
 876 (provide 'cwiki-common)
 877
 878 ;;; cwiki-common.el ends here