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