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://www.chise.org/glyphs")
  26
  27 (defvar chise-wiki-glyph-cgi-url
  28   "http://www.chise.org/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-genre uri-feature-name uri-object)
 368   (format "%s?feature=%s&%s=%s"
 369           chise-wiki-view-url uri-feature-name uri-genre uri-object))
 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 (defun www-uri-make-object-url (object &optional uri-object)
 458   (format "%s?%s=%s"
 459           chise-wiki-view-url
 460           (est-object-genre object)
 461           (or uri-object
 462               (www-uri-encode-object object))))
 463
 464
 465 ;;; @ Feature name presentation
 466 ;;;
 467
 468 (defun www-format-feature-name-default (feature-name)
 469   (mapconcat
 470    #'capitalize
 471    (split-string
 472     (symbol-name feature-name)
 473     "-")
 474    " "))
 475
 476 (defun www-format-feature-name-as-metadata (feature-name &optional lang)
 477   (let ((str (symbol-name feature-name))
 478         base meta)
 479     (cond
 480      ((string-match "\\*[^*]+$" str)
 481       (setq base (substring str 0 (match-beginning 0))
 482             meta (substring str (match-beginning 0)))
 483       (concat (www-format-feature-name* (intern base) lang)
 484               meta))
 485      (t
 486       (www-format-feature-name-default feature-name)
 487       ))))
 488
 489 (defun www-format-feature-name-as-rel-to (feature-name)
 490   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 491
 492 (defun www-format-feature-name-as-rel-from (feature-name)
 493   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 494
 495 (defun www-format-feature-name-as-CCS (feature-name)
 496   (let* ((rest
 497           (split-string
 498            (symbol-name feature-name)
 499            "-"))
 500          (dest (upcase (pop rest))))
 501     (when (string-match "^=+>*" dest)
 502       (setq dest (concat (substring dest 0 (match-end 0))
 503                          " "
 504                          (substring dest (match-end 0)))))
 505     (cond
 506      (rest
 507       (while (cdr rest)
 508         (setq dest (concat dest " " (upcase (pop rest)))))
 509       (if (string-match "^[0-9]+$" (car rest))
 510           (concat dest "-" (car rest))
 511         (concat dest " " (upcase (car rest))))
 512       )
 513      (t dest))))
 514
 515 (defun www-format-feature-name* (feature-name &optional lang)
 516   (let (name fn parent ret)
 517     (cond
 518      ((or (and lang
 519                (char-feature-property
 520                 feature-name
 521                 (intern (format "name@%s" lang))))
 522           (char-feature-property
 523            feature-name 'name)))
 524      ((and (setq name (symbol-name feature-name))
 525            (string-match "\\*" name))
 526       (www-format-feature-name-as-metadata feature-name lang))
 527      (t
 528       (setq fn feature-name)
 529       (while (and (setq parent (char-feature-name-parent fn))
 530                   (null (setq ret
 531                               (or (and lang
 532                                        (char-feature-property
 533                                         parent
 534                                         (intern (format "name@%s" lang))))
 535                                   (char-feature-property
 536                                    parent 'name)))))
 537         (setq fn parent))
 538       (cond
 539        (ret
 540         (concat ret (substring (symbol-name feature-name)
 541                                (length (symbol-name parent)))))
 542        ((find-charset feature-name)
 543         (www-format-feature-name-as-CCS feature-name))
 544        ((string-match "^\\(->\\)" name)
 545         (www-format-feature-name-as-rel-to feature-name))
 546        ((string-match "^\\(<-\\)" name)
 547         (www-format-feature-name-as-rel-from feature-name))
 548        (t
 549         (www-format-feature-name-default feature-name)
 550         ))
 551       ))))
 552
 553 (defun www-format-feature-name (feature-name &optional lang)
 554   (www-format-encode-string
 555    (www-format-feature-name* feature-name lang)))
 556
 557
 558 ;;; @ HTML generator
 559 ;;;
 560
 561 (defvar www-format-char-img-style "vertical-align:bottom;")
 562
 563 (defun www-format-encode-string (string &optional without-tags as-body)
 564   (with-temp-buffer
 565     (insert string)
 566     (let (plane code start end char variants ret rret)
 567       (when as-body
 568         (goto-char (point-min))
 569         (while (search-forward "&" nil t)
 570           (replace-match "&amp;" nil t)))
 571       (goto-char (point-min))
 572       (while (search-forward "<" nil t)
 573         (replace-match "&lt;" nil t))
 574       (goto-char (point-min))
 575       (while (search-forward ">" nil t)
 576         (replace-match "&gt;" nil t))
 577       (if without-tags
 578           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 579         (let ((coded-charset-entity-reference-alist
 580                (list*
 581                 '(=gt                   "GT-" 5 d)
 582                 '(=cns11643-1           "C1-" 4 X)
 583                 '(=cns11643-2           "C2-" 4 X)
 584                 '(=cns11643-3           "C3-" 4 X)
 585                 '(=cns11643-4           "C4-" 4 X)
 586                 '(=cns11643-5           "C5-" 4 X)
 587                 '(=cns11643-6           "C6-" 4 X)
 588                 '(=cns11643-7           "C7-" 4 X)
 589                 '(=gb2312               "G0-" 4 X)
 590                 '(=gb12345              "G1-" 4 X)
 591                 '(=jis-x0208@1990       "J90-" 4 X)
 592                 '(=jis-x0212            "JSP-" 4 X)
 593                 '(=cbeta                "CB" 5 d)
 594                 '(=jis-x0208@1997       "J97-" 4 X)
 595                 '(=jis-x0208@1978       "J78-" 4 X)
 596                 '(=jis-x0208@1983       "J83-" 4 X)
 597                 '(=ruimoku-v6           "RUI6-" 4 X)
 598                 '(=zinbun-oracle        "ZOB-" 4 d)
 599                 '(=jef-china3           "JC3-" 4 X)
 600                 '(=daikanwa             "M-" 5 d)
 601                 coded-charset-entity-reference-alist)))
 602           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 603
 604           (goto-char (point-min))
 605           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 606             (setq code (string-to-int (match-string 1)))
 607             (replace-match
 608              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\"
 609 style=\"%s\">"
 610                      code
 611                      chise-wiki-bitmap-glyphs-url
 612                      (/ code 1000) code
 613                      www-format-char-img-style)
 614              t 'literal))
 615
 616           (goto-char (point-min))
 617           (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 618             (setq plane (match-string 1)
 619                   code (string-to-int (match-string 2) 16))
 620             (replace-match
 621              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\"
 622 style=\"%s\">"
 623                      plane code
 624                      chise-wiki-bitmap-glyphs-url
 625                      plane
 626                      (- (lsh code -8) 32)
 627                      (- (logand code 255) 32)
 628                      www-format-char-img-style)
 629              t 'literal))
 630
 631           (goto-char (point-min))
 632           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 633             (setq plane (string-to-int (match-string 1))
 634                   code (string-to-int (match-string 2) 16))
 635             (replace-match
 636              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\"
 637 style=\"%s\">"
 638                      plane code
 639                      chise-wiki-bitmap-glyphs-url
 640                      plane
 641                      (- (lsh code -8) 32)
 642                      (- (logand code 255) 32)
 643                      www-format-char-img-style)
 644              t 'literal))
 645
 646           (goto-char (point-min))
 647           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 648             (setq plane (string-to-int (match-string 1))
 649                   code (string-to-int (match-string 2) 16))
 650             (replace-match
 651              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\"
 652 style=\"%s\">"
 653                      plane code
 654                      chise-wiki-bitmap-glyphs-url
 655                      plane code
 656                      www-format-char-img-style)
 657              t 'literal))
 658
 659           (goto-char (point-min))
 660           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 661             (setq code (string-to-int (match-string 1) 16))
 662             (replace-match
 663              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 664                      code code)
 665              t 'literal))
 666
 667           (goto-char (point-min))
 668           (while (re-search-forward "&\\(A-\\)?ZOB-\\([0-9]+\\);" nil t)
 669             (setq code (string-to-int (match-string 2)))
 670             (replace-match
 671              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\"
 672 style=\"vertical-align:middle\">"
 673                      code
 674                      chise-wiki-bitmap-glyphs-url
 675                      code
 676                      www-format-char-img-style)
 677              t 'literal))
 678
 679           (goto-char (point-min))
 680           (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
 681             (setq code (string-to-int (match-string 2)))
 682             (replace-match
 683              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\"
 684 style=\"%s\">"
 685                      code
 686                      chise-wiki-glyph-cgi-url
 687                      code
 688                      www-format-char-img-style)
 689              t 'literal))
 690
 691           (goto-char (point-min))
 692           (while (re-search-forward "&\\(G-\\)?GT-K\\([0-9]+\\);" nil t)
 693             (setq code (string-to-int (match-string 2)))
 694             (replace-match
 695              (format "<img alt=\"GT-K%05d\" src=\"%s?char=GT-K%05d\"
 696 style=\"%s\">"
 697                      code
 698                      chise-wiki-glyph-cgi-url
 699                      code
 700                      www-format-char-img-style)
 701              t 'literal))
 702
 703           (goto-char (point-min))
 704           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 705             (setq code (string-to-int (match-string 1) 16))
 706             (replace-match
 707              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\"
 708 style=\"%s\">"
 709                      code
 710                      chise-wiki-glyph-cgi-url
 711                      code
 712                      www-format-char-img-style)
 713              t 'literal))
 714
 715           (goto-char (point-min))
 716           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 717             (setq code (string-to-int (match-string 1) 16))
 718             (replace-match
 719              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\"
 720 style=\"%s\">"
 721                      code
 722                      chise-wiki-glyph-cgi-url
 723                      code
 724                      www-format-char-img-style)
 725              t 'literal))
 726
 727           (goto-char (point-min))
 728           (while (re-search-forward "&RUI6-\\([0-9A-F]+\\);" nil t)
 729             (setq code (string-to-int (match-string 1) 16))
 730             (replace-match
 731              (format "<img alt=\"RUI6-%04X\" src=\"%s?char=RUI6-%04X\"
 732 style=\"vertical-align:middle\">"
 733                      code
 734                      chise-wiki-glyph-cgi-url
 735                      code
 736                      www-format-char-img-style)
 737              t 'literal))
 738
 739           (goto-char (point-min))
 740           (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t)
 741             (setq code (string-to-int (match-string 2) 16))
 742             (replace-match
 743              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\"
 744 style=\"vertical-align:middle\">"
 745                      code
 746                      code
 747                      www-format-char-img-style)
 748              t 'literal))
 749
 750           (goto-char (point-min))
 751           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 752             (setq code (string-to-int (match-string 1) 16))
 753             (setq start (match-beginning 0)
 754                   end (match-end 0))
 755             (setq char (decode-char 'system-char-id code))
 756             (cond
 757              ((and (setq variants
 758                          (or (www-get-feature-value char '->subsumptive)
 759                              (www-get-feature-value char '->denotational)))
 760                    (progn
 761                      (while (and variants
 762                                  (setq ret (www-format-encode-string
 763                                             (char-to-string (car variants))))
 764                                  (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 765                        (setq variants (cdr variants)))
 766                      ret))
 767               (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 768                 (goto-char start)
 769                 (delete-region start end)
 770                 (insert ret))
 771               )
 772              ((setq ret (or (www-get-feature-value char 'ideographic-combination)
 773                             (www-get-feature-value char 'ideographic-structure)))
 774               (setq ret
 775                     (mapconcat
 776                      (lambda (ch)
 777                        (if (listp ch)
 778                            (if (characterp (setq rret (find-char ch)))
 779                                (setq ch rret)))
 780                        (if (characterp ch)
 781                            (www-format-encode-string
 782                             (char-to-string ch) without-tags)
 783                          (www-format-encode-string
 784                           (format "%S" ch) without-tags)))
 785                      ret ""))
 786               (when ret
 787                 (goto-char start)
 788                 (delete-region start end)
 789                 (insert ret))
 790               )))
 791           ))
 792       ;; (goto-char (point-min))
 793       ;; (while (search-forward "&GT-" nil t)
 794       ;;   (replace-match "&amp;GT-" t 'literal))
 795       (buffer-string))))
 796
 797 (defun www-html-display-text (text)
 798   (princ
 799    (with-temp-buffer
 800      (insert text)
 801      (goto-char (point-min))
 802      (while (search-forward "<" nil t)
 803        (replace-match "&lt;" nil t))
 804      (goto-char (point-min))
 805      (while (search-forward ">" nil t)
 806        (replace-match "&gt;" nil t))
 807      (goto-char (point-min))
 808      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
 809        (replace-match
 810         (format "<a href=\"%s\">%s</a>"
 811                 (match-string 2)
 812                 (match-string 1))
 813         nil t))
 814      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 815      (goto-char (point-min))
 816      (while (search-forward "&GT-" nil t)
 817        (replace-match "&amp;GT-" nil t))
 818      (buffer-string))))
 819
 820 (defun www-html-display-paragraph (text)
 821   (princ "<p>")
 822   (www-html-display-text text)
 823   (princ "</p>\n"))
 824
 825
 826 ;;; @ for GlyphWiki
 827 ;;;
 828
 829 (defvar coded-charset-GlyphWiki-id-alist
 830   '((=ucs               "u"     4 x nil)
 831     (=ucs@JP            "u"     4 x nil)
 832     (=ucs@jis           "u"     4 x nil)
 833     (=ucs@gb            "u"     4 x "-g")
 834     (=ucs@cns           "u"     4 x "-t")
 835     (=ucs@ks            "u"     4 x "-k")
 836     (=ucs@iso           "u"     4 x "-u")
 837     (=ucs@unicode       "u"     4 x "-us")
 838     (=adobe-japan1-6    "aj1-"  5 d nil)
 839     (=gt                "gt-"   5 d nil)
 840     (=big5-cdp          "cdp-"  4 x nil)
 841     (=cbeta             "cb"    5 d nil)
 842     (=jis-x0208@1978/1pr "j78-" 4 x nil)
 843     (=jis-x0208@1978/-4pr "j78-" 4 x nil)
 844     (=jis-x0208@1978    "j78-"  4 x nil)
 845     (=jis-x0208@1983    "j83-"  4 x nil)
 846     (=jis-x0208@1990    "j90-"  4 x nil)
 847     (=jis-x0212         "jsp-"  4 x nil)
 848     (=jis-x0213-1@2000  "jx1-2000-" 4 x nil)
 849     (=jis-x0213-1@2004  "jx1-2004-" 4 x nil)
 850     (=jis-x0213-2       "jx2-"  4 x nil)
 851     (=cns11643-1        "c1-"   4 x nil)
 852     (=cns11643-2        "c2-"   4 x nil)
 853     (=cns11643-3        "c3-"   4 x nil)
 854     (=cns11643-4        "c4-"   4 x nil)
 855     (=cns11643-5        "c5-"   4 x nil)
 856     (=cns11643-6        "c6-"   4 x nil)
 857     (=cns11643-7        "c7-"   4 x nil)
 858     (=daikanwa          "dkw-"  5 d nil)
 859     (=gt-k              "gt-k"  5 d nil)
 860     (=jef-china3        "jc3-"  4 x nil)
 861     (=big5              "b-"    4 x nil)
 862     (=ks-x1001          "k0-"   4 x nil)
 863     ))
 864
 865 (defun char-GlyphWiki-id (char)
 866   (let ((rest coded-charset-GlyphWiki-id-alist)
 867         spec ret code)
 868     (while (and rest
 869                 (setq spec (pop rest))
 870                 (null (setq ret (char-feature char (car spec))))))
 871     (when ret
 872       (or
 873        (and (memq (car spec) '(=ucs@unicode '=ucs@iso))
 874             (cond
 875              ((and (or (encode-char char '=jis-x0208@1990)
 876                        (encode-char char '=jis-x0212)
 877                        (encode-char char '=jis-x0213-1))
 878                    (setq code (encode-char char '=ucs@jis)))
 879               (format "u%04x" code)
 880               )
 881              ((and (or (encode-char char '=gb2312)
 882                        (encode-char char '=gb12345))
 883                    (setq code (encode-char char '=ucs@gb)))
 884               (format "u%04x-g" code)
 885               )
 886              ((and (or (encode-char char '=cns11643-1)
 887                        (encode-char char '=cns11643-2)
 888                        (encode-char char '=cns11643-3)
 889                        (encode-char char '=cns11643-4)
 890                        (encode-char char '=cns11643-5)
 891                        (encode-char char '=cns11643-6)
 892                        (encode-char char '=cns11643-7))
 893                    (setq code (encode-char char '=ucs@cns)))
 894               (format "u%04x-t" code)
 895               )
 896              ((and (encode-char char '=ks-x1001)
 897                    (setq code (encode-char char '=ucs@ks)))
 898               (format "u%04x-k" code)
 899               )))
 900        (format (format "%s%%0%d%s%s"
 901                        (nth 1 spec)
 902                        (nth 2 spec)
 903                        (nth 3 spec)
 904                        (or (nth 4 spec) ""))
 905                ret)))))
 906
 907
 908 ;;; @ End.
 909 ;;;
 910
 911 (provide 'cwiki-common)
 912
 913 ;;; cwiki-common.el ends here