cwiki-common.el

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