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/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 "^\\(->\\|<-\\)" str)
  39           'relation)
  40          ((string-match "^ideographic-structure\\(@\\|$\\)" str)
  41           'structure)
  42          ))))
  43
  44 (defun www-feature-value-format (feature-name)
  45   (or (char-feature-property feature-name 'value-format)
  46       (let ((type (www-feature-type feature-name)))
  47         (cond ((eq type 'relation)
  48                'space-separated-char-list)
  49               ((eq type 'structure)
  50                'space-separated-ids)))
  51       (if (find-charset feature-name)
  52           (if (and (= (charset-dimension feature-name) 2)
  53                    (= (charset-chars feature-name) 94))
  54               '("0x" (HEX)
  55                 " (" (decimal) ") <" (ku-ten) ">")
  56             '("0x" (HEX) " (" (decimal) ")")))))
  57
  58 (defun char-feature-name-at-domain (feature-name domain)
  59   (let ((name (symbol-name feature-name)))
  60     (cond
  61      ((string-match "@[^*]+$" name)
  62       (intern (format "%s/%s" name domain))
  63       )
  64      (t
  65       (intern (format "%s@%s" name domain))
  66       ))))
  67
  68 (defun www-char-feature (character feature)
  69   (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest)))
  70     (mount-char-attribute-table latest-feature)
  71     (or (char-feature character latest-feature)
  72         (char-feature character feature))))
  73
  74
  75 ;;; @ URI representation
  76 ;;;
  77
  78 (defun www-uri-decode-feature-name (uri-feature)
  79   (let (feature)
  80     (cond
  81      ((string-match "^from\\." uri-feature)
  82       (intern (format "<-%s" (substring uri-feature (match-end 0))))
  83       )
  84      ((string-match "^to\\." uri-feature)
  85       (intern (format "->%s" (substring uri-feature (match-end 0))))
  86       )
  87      ((string-match "^rep\\." uri-feature)
  88       (intern (format "=%s" (substring uri-feature (match-end 0))))
  89       )
  90      ((string-match "^g\\." uri-feature)
  91       (intern (format "=>>%s" (substring uri-feature (match-end 0))))
  92       )
  93      ((string-match "^gi\\." uri-feature)
  94       (intern (format "=>>>%s" (substring uri-feature (match-end 0))))
  95       )
  96      ((string-match "^gi\\([0-9]+\\)\\." uri-feature)
  97       (intern (format "=>>%s%s"
  98                       (make-string (string-to-int
  99                                     (match-string 1 uri-feature))
 100                                    ?>)
 101                       (substring uri-feature (match-end 0))))
 102       )
 103      ((string-match "^a\\." uri-feature)
 104       (intern (format "=>%s" (substring uri-feature (match-end 0))))
 105       )
 106      ((string-match "^a\\([0-9]+\\)\\." uri-feature)
 107       (intern (format "%s>%s"
 108                       (make-string (string-to-int
 109                                     (match-string 1 uri-feature))
 110                                    ?=)
 111                       (substring uri-feature (match-end 0))))
 112       )
 113      ((and (setq feature (intern (format "=>%s" uri-feature)))
 114            (find-charset feature))
 115       feature)
 116      ((and (setq feature (intern (format "=>>%s" uri-feature)))
 117            (find-charset feature))
 118       feature)
 119      ((and (setq feature (intern (format "=>>>%s" uri-feature)))
 120            (find-charset feature))
 121       feature)
 122      ((and (setq feature (intern (format "=%s" uri-feature)))
 123            (find-charset feature))
 124       feature)
 125      (t (intern uri-feature)))))
 126
 127 (defun www-uri-encode-feature-name (feature-name)
 128   (setq feature-name (symbol-name feature-name))
 129   (cond
 130    ((string-match "^=\\([^=>]+\\)" feature-name)
 131     (concat "rep." (substring feature-name (match-beginning 1)))
 132     )
 133    ((string-match "^=>>\\([^=>]+\\)" feature-name)
 134     (concat "g." (substring feature-name (match-beginning 1)))
 135     )
 136    ((string-match "^=>>>\\([^=>]+\\)" feature-name)
 137     (concat "gi." (substring feature-name (match-beginning 1)))
 138     )
 139    ((string-match "^=>>\\(>+\\)" feature-name)
 140     (format "gi%d.%s"
 141             (length (match-string 1 feature-name))
 142             (substring feature-name (match-end 1)))
 143     )
 144    ((string-match "^=>\\([^=>]+\\)" feature-name)
 145     (concat "a." (substring feature-name (match-beginning 1)))
 146     )
 147    ((string-match "^\\(=+\\)>" feature-name)
 148     (format "a%d.%s"
 149             (length (match-string 1 feature-name))
 150             (substring feature-name (match-end 0)))
 151     )
 152    ((string-match "^->" feature-name)
 153     (concat "to." (substring feature-name (match-end 0)))
 154     )
 155    ((string-match "^<-" feature-name)
 156     (concat "from." (substring feature-name (match-end 0)))
 157     )
 158    (t feature-name)))
 159
 160 (defun www-uri-decode-char (char-rep)
 161   (let (ccs cpos)
 162     (cond
 163      ((string-match "\\(%3A\\|:\\)" char-rep)
 164       (setq ccs (substring char-rep 0 (match-beginning 0))
 165             cpos (substring char-rep (match-end 0)))
 166       (setq ccs (www-uri-decode-feature-name ccs))
 167       (cond
 168        ((string-match "^0x" cpos)
 169         (setq cpos
 170               (string-to-number (substring cpos (match-end 0)) 16))
 171         )
 172        (t
 173         (setq cpos (string-to-number cpos))
 174         ))
 175       (if (numberp cpos)
 176           (decode-char ccs cpos))
 177       )
 178      (t
 179       (setq char-rep (decode-uri-string char-rep 'utf-8-mcs-er))
 180       (when (= (length char-rep) 1)
 181         (aref char-rep 0))
 182       ))))
 183
 184 (defun www-uri-encode-char (char)
 185   (if (encode-char char '=ucs)
 186       (mapconcat
 187        (lambda (byte)
 188          (format "%%%02X" byte))
 189        (encode-coding-string (char-to-string char) 'utf-8-mcs-er)
 190        "")
 191     (let ((ccs-list '(; =ucs
 192                       =cns11643-1 =cns11643-2 =cns11643-3
 193                       =cns11643-4 =cns11643-5 =cns11643-6 =cns11643-7
 194                       =gb2312 =gb12345
 195                       =jis-x0208 =jis-x0208@1990
 196                       =jis-x0212
 197                       =cbeta =jef-china3
 198                       =jis-x0213-1@2000 =jis-x0213-1@2004
 199                       =jis-x0208@1983 =jis-x0208@1978
 200                       =zinbun-oracle
 201                       =daikanwa
 202                       =gt =gt-k
 203                       =>>jis-x0208 =>>jis-x0213-1
 204                       =>jis-x0208 =>jis-x0213-1
 205                       =>>gt
 206                       =big5
 207                       =big5-cdp))
 208           ccs ret)
 209       (while (and ccs-list
 210                   (setq ccs (pop ccs-list))
 211                   (not (setq ret (encode-char char ccs 'defined-only)))))
 212       (cond (ret
 213              (format "%s:0x%X"
 214                      (www-uri-encode-feature-name ccs)
 215                      ret))
 216             ((and (setq ccs (car (split-char char)))
 217                   (setq ret (encode-char char ccs)))
 218              (format "%s:0x%X"
 219                      (www-uri-encode-feature-name ccs)
 220                      ret))
 221             (t
 222              (format "system-char-id:0x%X"
 223                      (encode-char char 'system-char-id))
 224              )))))
 225
 226
 227 ;;; @ Feature name presentation
 228 ;;;
 229
 230 (defun www-format-feature-name-default (feature-name)
 231   (mapconcat
 232    #'capitalize
 233    (split-string
 234     (symbol-name feature-name)
 235     "-")
 236    " "))
 237
 238 (defun www-format-feature-name-as-rel-to (feature-name)
 239   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 240
 241 (defun www-format-feature-name-as-rel-from (feature-name)
 242   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 243
 244 (defun www-format-feature-name-as-CCS (feature-name)
 245   (let* ((rest
 246           (split-string
 247            (symbol-name feature-name)
 248            "-"))
 249          (dest (upcase (pop rest))))
 250     (when (string-match "^=+>*" dest)
 251       (setq dest (concat (substring dest 0 (match-end 0))
 252                          " "
 253                          (substring dest (match-end 0)))))
 254     (cond
 255      (rest
 256       (while (cdr rest)
 257         (setq dest (concat dest " " (upcase (pop rest)))))
 258       (if (string-match "^[0-9]+$" (car rest))
 259           (concat dest "-" (car rest))
 260         (concat dest " " (upcase (car rest))))
 261       )
 262      (t dest))))
 263
 264 (defun www-format-feature-name* (feature-name &optional lang)
 265   (let (name)
 266     (cond
 267      ((or (and lang
 268                (char-feature-property
 269                 feature-name
 270                 (intern (format "name@%s" lang))))
 271           (char-feature-property
 272            feature-name 'name)))
 273      ((find-charset feature-name)
 274       (www-format-feature-name-as-CCS feature-name))
 275      ((and (setq name (symbol-name feature-name))
 276            (string-match "^\\(->\\)" name))
 277       (www-format-feature-name-as-rel-to feature-name))
 278      ((string-match "^\\(<-\\)" name)
 279       (www-format-feature-name-as-rel-from feature-name))
 280      (t
 281       (www-format-feature-name-default feature-name)))))
 282
 283 (defun www-format-feature-name (feature-name &optional lang)
 284   (www-format-encode-string
 285    (www-format-feature-name* feature-name lang)))
 286
 287
 288 ;;; @ Feature value presentation
 289 ;;;
 290
 291 (defun www-format-value-as-kuten (value)
 292   (format "%02d-%02d"
 293           (- (lsh value -8) 32)
 294           (- (logand value 255) 32)))
 295
 296 (defun www-format-value-as-char-list (value &optional without-tags)
 297   (if (listp value)
 298       (mapconcat
 299        (if without-tags
 300            (lambda (unit)
 301              (www-format-encode-string
 302               (format (if (characterp unit)
 303                           "%c"
 304                         "%s")
 305                       unit)
 306               'without-tags))
 307          (lambda (unit)
 308            (if (characterp unit)
 309                (format "<a href=\"%s?char=%s\">%s</a>"
 310                        chise-wiki-view-url
 311                        (www-uri-encode-char unit)
 312                        (www-format-encode-string (char-to-string unit)))
 313              (www-format-encode-string (format "%s" unit)))))
 314        value " ")
 315     (www-format-encode-string (format "%s" value) without-tags)))
 316
 317 (defun www-format-value-as-ids (value &optional without-tags)
 318   (if (listp value)
 319       (mapconcat
 320        (if without-tags
 321            (lambda (unit)
 322              (www-format-encode-string
 323               (format (if (characterp unit)
 324                           "%c"
 325                         "%s")
 326                       unit)
 327               'without-tags))
 328          (lambda (unit)
 329            (if (characterp unit)
 330                (format "<a href=\"%s?char=%s\">%s</a>"
 331                        chise-wiki-view-url
 332                        (www-uri-encode-char unit)
 333                        (www-format-encode-string (char-to-string unit)))
 334              (www-format-encode-string (format "%s" unit)))))
 335        (ideographic-structure-to-ids value) " ")
 336     (www-format-encode-string (format "%s" value) without-tags)))
 337
 338 (defun www-format-value-as-S-exp (value &optional without-tags)
 339   (www-format-encode-string (format "%S" value) without-tags))
 340
 341 (defun www-format-value-as-HEX (value)
 342   (if (integerp value)
 343       (format "%X" value)
 344     (www-format-value-as-S-exp value)))
 345
 346 (defun www-format-value-as-CCS-default (value)
 347   (if (integerp value)
 348       (format "0x%s (%d)"
 349               (www-format-value-as-HEX value)
 350               value)
 351     (www-format-value-as-S-exp value)))
 352
 353 (defun www-format-value-as-CCS-94x94 (value)
 354   (if (integerp value)
 355       (format "0x%s [%s] (%d)"
 356               (www-format-value-as-HEX value)
 357               (www-format-value-as-kuten value)
 358               value)
 359     (www-format-value-as-S-exp value)))
 360
 361 (defun www-format-value (value &optional feature-name format without-tags)
 362   ;; (cond
 363   ;;  ((find-charset feature-name)
 364   ;;   (cond
 365   ;;    ((and (= (charset-chars feature-name) 94)
 366   ;;          (= (charset-dimension feature-name) 2))
 367   ;;     (www-format-value-as-CCS-94x94 value))
 368   ;;    (t
 369   ;;     (www-format-value-as-CCS-default value)))
 370   ;;   )
 371   ;;  (t
 372   ;;   (www-format-value-as-S-exp value)))
 373   (www-format-apply-value format nil value nil nil without-tags)
 374   )
 375
 376
 377 ;;; @ format evaluator
 378 ;;;
 379
 380 (defun www-format-encode-string (string &optional without-tags)
 381   (with-temp-buffer
 382     (insert string)
 383     (let (plane code start end char variants ret)
 384       (goto-char (point-min))
 385       (while (search-forward "<" nil t)
 386         (replace-match "&lt;" nil t))
 387       (goto-char (point-min))
 388       (while (search-forward ">" nil t)
 389         (replace-match "&gt;" nil t))
 390       (if without-tags
 391           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 392         (let ((coded-charset-entity-reference-alist
 393                (list*
 394                 '(=cns11643-1           "C1-" 4 X)
 395                 '(=cns11643-2           "C2-" 4 X)
 396                 '(=cns11643-3           "C3-" 4 X)
 397                 '(=cns11643-4           "C4-" 4 X)
 398                 '(=cns11643-5           "C5-" 4 X)
 399                 '(=cns11643-6           "C6-" 4 X)
 400                 '(=cns11643-7           "C7-" 4 X)
 401                 '(=gb2312               "G0-" 4 X)
 402                 '(=gb12345              "G1-" 4 X)
 403                 '(=jis-x0208@1990       "J90-" 4 X)
 404                 '(=jis-x0212            "JSP-" 4 X)
 405                 '(=cbeta                "CB" 5 d)
 406                 '(=jis-x0208@1997       "J97-" 4 X)
 407                 '(=jis-x0208@1978       "J78-" 4 X)
 408                 '(=jis-x0208@1983       "J83-" 4 X)
 409                 '(=gt                   "GT-" 5 d)
 410                 '(=zinbun-oracle        "ZOB-" 4 d)
 411                 '(=jef-china3           "JC3-" 4 X)
 412                 '(=daikanwa             "M-" 5 d)
 413                 coded-charset-entity-reference-alist)))
 414           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 415
 416           (goto-char (point-min))
 417           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 418             (setq code (string-to-int (match-string 1)))
 419             (replace-match
 420              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
 421                      code
 422                      chise-wiki-bitmap-glyphs-url
 423                      (/ code 1000) code)
 424              t 'literal))
 425
 426           (goto-char (point-min))
 427           (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 428             (setq plane (match-string 1)
 429                   code (string-to-int (match-string 2) 16))
 430             (replace-match
 431              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
 432                      plane code
 433                      chise-wiki-bitmap-glyphs-url
 434                      plane
 435                      (- (lsh code -8) 32)
 436                      (- (logand code 255) 32))
 437              t 'literal))
 438
 439           (goto-char (point-min))
 440           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 441             (setq plane (string-to-int (match-string 1))
 442                   code (string-to-int (match-string 2) 16))
 443             (replace-match
 444              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
 445                      plane code
 446                      chise-wiki-bitmap-glyphs-url
 447                      plane
 448                      (- (lsh code -8) 32)
 449                      (- (logand code 255) 32))
 450              t 'literal))
 451
 452           (goto-char (point-min))
 453           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 454             (setq plane (string-to-int (match-string 1))
 455                   code (string-to-int (match-string 2) 16))
 456             (replace-match
 457              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
 458                      plane code
 459                      chise-wiki-bitmap-glyphs-url
 460                      plane code)
 461              t 'literal))
 462
 463           (goto-char (point-min))
 464           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 465             (setq code (string-to-int (match-string 1) 16))
 466             (replace-match
 467              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 468                      code code)
 469              t 'literal))
 470
 471           (goto-char (point-min))
 472           (while (re-search-forward "&ZOB-\\([0-9]+\\);" nil t)
 473             (setq code (string-to-int (match-string 1)))
 474             (replace-match
 475              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
 476                      code
 477                      chise-wiki-bitmap-glyphs-url
 478                      code)
 479              t 'literal))
 480
 481           (goto-char (point-min))
 482           (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
 483             (setq code (string-to-int (match-string 2)))
 484             (replace-match
 485              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
 486                      code
 487                      chise-wiki-glyph-cgi-url
 488                      code)
 489              t 'literal))
 490
 491           (goto-char (point-min))
 492           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 493             (setq code (string-to-int (match-string 1) 16))
 494             (replace-match
 495              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
 496                      code
 497                      chise-wiki-glyph-cgi-url
 498                      code)
 499              t 'literal))
 500
 501           (goto-char (point-min))
 502           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 503             (setq code (string-to-int (match-string 1) 16))
 504             (replace-match
 505              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
 506                      code
 507                      chise-wiki-glyph-cgi-url
 508                      code)
 509              t 'literal))
 510
 511           (goto-char (point-min))
 512           (while (re-search-forward "&UU\\+\\([0-9A-F]+\\);" nil t)
 513             (setq code (string-to-int (match-string 1) 16))
 514             (replace-match
 515              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
 516                      code
 517                      code)
 518              t 'literal))
 519
 520           (goto-char (point-min))
 521           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 522             (setq code (string-to-int (match-string 1) 16))
 523             (setq start (match-beginning 0)
 524                   end (match-end 0))
 525             (setq char (decode-char 'system-char-id code))
 526             (setq variants (or (www-char-feature char '->subsumptive)
 527                                (www-char-feature char '->denotational)))
 528             (while (and variants
 529                         (setq ret (www-format-encode-string
 530                                    (char-to-string (car variants))))
 531                         (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 532               (setq variants (cdr variants)))
 533             (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 534               (goto-char start)
 535               (delete-region start end)
 536               (insert ret)))
 537           ))
 538       ;; (goto-char (point-min))
 539       ;; (while (search-forward "&GT-" nil t)
 540       ;;   (replace-match "&amp;GT-" t 'literal))
 541       (buffer-string))))
 542
 543 (defun www-format-props-to-string (props &optional format)
 544   (unless format
 545     (setq format (plist-get props :format)))
 546   (concat "%"
 547           (plist-get props :flag)
 548           (if (plist-get props :zero-padding)
 549               "0")
 550           (if (plist-get props :len)
 551               (format "%d" (plist-get props :len)))
 552           (cond
 553            ((eq format 'decimal) "d")
 554            ((eq format 'hex) "x")
 555            ((eq format 'HEX) "X")
 556            ((eq format 'S-exp) "S")
 557            (t "s"))))
 558
 559 (defun www-format-apply-value (format props value
 560                                       &optional uri-char uri-feature
 561                                       without-tags)
 562   (let (ret)
 563     (setq ret
 564           (cond
 565            ((memq format '(decimal hex HEX))
 566             (if (integerp value)
 567                 (format (www-format-props-to-string props format)
 568                         value)
 569               (www-format-encode-string
 570                (format "%s" value)
 571                without-tags))
 572             )
 573            ((eq format 'S-exp)
 574             (www-format-encode-string
 575              (format (www-format-props-to-string props format)
 576                      value)
 577              without-tags))
 578            ((eq format 'ku-ten)
 579             (www-format-value-as-kuten value))
 580            ((eq format 'space-separated-char-list)
 581             (www-format-value-as-char-list value without-tags))
 582            ((eq format 'space-separated-ids)
 583             (www-format-value-as-ids value without-tags))
 584            (t
 585             (setq format 'default)
 586             (www-format-encode-string
 587              (format (www-format-props-to-string props 'default)
 588                      value)
 589              without-tags))))
 590     (if (or without-tags (eq (plist-get props :mode) 'peek))
 591         ret
 592       (format "%s <a href=\"%s?char=%s&feature=%s&format=%s\"
 593 ><input type=\"submit\" value=\"edit\" /></a>"
 594               ret
 595               chise-wiki-edit-url
 596               uri-char uri-feature format))))
 597
 598 (defun www-format-eval-feature-value (char
 599                                       feature-name
 600                                       &optional format lang uri-char value)
 601   (unless value
 602     (setq value (www-char-feature char feature-name)))
 603   (unless format
 604     (setq format (www-feature-value-format feature-name)))
 605   (cond
 606    ((symbolp format)
 607     (www-format-apply-value
 608      format nil value
 609      uri-char (www-uri-encode-feature-name feature-name))
 610     )
 611    ((consp format)
 612     (cond ((null (cdr format))
 613            (setq format (car format))
 614            (www-format-apply-value
 615             (car format) (nth 1 format) value
 616             uri-char (www-uri-encode-feature-name feature-name))
 617            )
 618           (t
 619            (www-format-eval-list format char feature-name lang uri-char)
 620            )))))
 621
 622 (defun www-format-eval-unit (exp char feature-name
 623                                  &optional lang uri-char value)
 624   (unless value
 625     (setq value (www-char-feature char feature-name)))
 626   (unless uri-char
 627     (setq uri-char (www-uri-encode-char char)))
 628   (cond
 629    ((stringp exp) (www-format-encode-string exp))
 630    ((null exp) "")
 631    ((consp exp)
 632     (cond
 633      ((memq (car exp) '(value decimal hex HEX ku-ten S-exp default))
 634       (if (eq (car exp) 'value)
 635           (www-format-eval-feature-value char feature-name
 636                                          (plist-get (nth 1 exp) :format)
 637                                          lang uri-char value)
 638         (www-format-apply-value
 639          (car exp) (nth 1 exp) value
 640          uri-char (www-uri-encode-feature-name feature-name)))
 641       )
 642      ((eq (car exp) 'name)
 643       (format "<a href=\"%s?feature=%s&char=%s\">%s</a>"
 644               chise-wiki-view-url
 645               (www-uri-encode-feature-name feature-name)
 646               uri-char
 647               (www-format-feature-name feature-name lang))
 648       )
 649      ((eq (car exp) 'link)
 650       (format "<a
 651  href=\"%s\"
 652 >%s</a
 653 >"
 654               (www-format-eval-list (plist-get (nth 1 exp) :ref)
 655                                     char feature-name lang uri-char)
 656               (www-format-eval-list (nthcdr 2 exp)
 657                                     char feature-name lang uri-char)))
 658      (t
 659       (format "<%s
 660 >%s</%s
 661 >"
 662               (car exp)
 663               (www-format-eval-list (nthcdr 2 exp) char feature-name
 664                                     lang uri-char)
 665               (car exp)))))))
 666
 667 (defun www-format-eval-list (format-list char feature-name
 668                                          &optional lang uri-char)
 669   (if (consp format-list)
 670       (mapconcat
 671        (lambda (exp)
 672          (www-format-eval-unit exp char feature-name lang uri-char))
 673        format-list "")
 674     (www-format-eval-unit format-list char feature-name lang uri-char)))
 675
 676
 677 ;;; @ HTML generator
 678 ;;;
 679
 680 (defun www-html-display-text (text)
 681   (princ
 682    (with-temp-buffer
 683      (insert text)
 684      (goto-char (point-min))
 685      (while (search-forward "<" nil t)
 686        (replace-match "&lt;" nil t))
 687      (goto-char (point-min))
 688      (while (search-forward ">" nil t)
 689        (replace-match "&gt;" nil t))
 690      (goto-char (point-min))
 691      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
 692        (replace-match
 693         (format "<a href=\"%s\">%s</a>"
 694                 (match-string 2)
 695                 (match-string 1))
 696         nil t))
 697      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 698      (goto-char (point-min))
 699      (while (search-forward "&GT-" nil t)
 700        (replace-match "&amp;GT-" nil t))
 701      (buffer-string))))
 702
 703 (defun www-html-display-paragraph (text)
 704   (princ "<p>")
 705   (www-html-display-text text)
 706   (princ "</p>\n"))
 707
 708 (provide 'cwiki-common)