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 "\\*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
 216                       =daikanwa
 217                       =gt =gt-k
 218                       =>>jis-x0208 =>>jis-x0213-1
 219                       =>jis-x0208 =>jis-x0213-1
 220                       =>>gt
 221                       =big5
 222                       =big5-cdp))
 223           ccs ret)
 224       (while (and ccs-list
 225                   (setq ccs (pop ccs-list))
 226                   (not (setq ret (encode-char char ccs 'defined-only)))))
 227       (cond (ret
 228              (format "%s:0x%X"
 229                      (www-uri-encode-feature-name ccs)
 230                      ret))
 231             ((and (setq ccs (car (split-char char)))
 232                   (setq ret (encode-char char ccs)))
 233              (format "%s:0x%X"
 234                      (www-uri-encode-feature-name ccs)
 235                      ret))
 236             (t
 237              (format "system-char-id:0x%X"
 238                      (encode-char char 'system-char-id))
 239              )))))
 240
 241
 242 ;;; @ Feature name presentation
 243 ;;;
 244
 245 (defun www-format-feature-name-default (feature-name)
 246   (mapconcat
 247    #'capitalize
 248    (split-string
 249     (symbol-name feature-name)
 250     "-")
 251    " "))
 252
 253 (defun www-format-feature-name-as-rel-to (feature-name)
 254   (concat "\u2192" (substring (symbol-name feature-name) 2)))
 255
 256 (defun www-format-feature-name-as-rel-from (feature-name)
 257   (concat "\u2190" (substring (symbol-name feature-name) 2)))
 258
 259 (defun www-format-feature-name-as-CCS (feature-name)
 260   (let* ((rest
 261           (split-string
 262            (symbol-name feature-name)
 263            "-"))
 264          (dest (upcase (pop rest))))
 265     (when (string-match "^=+>*" dest)
 266       (setq dest (concat (substring dest 0 (match-end 0))
 267                          " "
 268                          (substring dest (match-end 0)))))
 269     (cond
 270      (rest
 271       (while (cdr rest)
 272         (setq dest (concat dest " " (upcase (pop rest)))))
 273       (if (string-match "^[0-9]+$" (car rest))
 274           (concat dest "-" (car rest))
 275         (concat dest " " (upcase (car rest))))
 276       )
 277      (t dest))))
 278
 279 (defun www-format-feature-name* (feature-name &optional lang)
 280   (let (name)
 281     (cond
 282      ((or (and lang
 283                (char-feature-property
 284                 feature-name
 285                 (intern (format "name@%s" lang))))
 286           (char-feature-property
 287            feature-name 'name)))
 288      ((find-charset feature-name)
 289       (www-format-feature-name-as-CCS feature-name))
 290      ((and (setq name (symbol-name feature-name))
 291            (string-match "^\\(->\\)" name))
 292       (www-format-feature-name-as-rel-to feature-name))
 293      ((string-match "^\\(<-\\)" name)
 294       (www-format-feature-name-as-rel-from feature-name))
 295      (t
 296       (www-format-feature-name-default feature-name)))))
 297
 298 (defun www-format-feature-name (feature-name &optional lang)
 299   (www-format-encode-string
 300    (www-format-feature-name* feature-name lang)))
 301
 302
 303 ;;; @ Feature value presentation
 304 ;;;
 305
 306 (defun www-format-value-as-kuten (value)
 307   (format "%02d-%02d"
 308           (- (lsh value -8) 32)
 309           (- (logand value 255) 32)))
 310
 311 (defun www-format-value-as-char-list (value &optional without-tags)
 312   (if (listp value)
 313       (mapconcat
 314        (if without-tags
 315            (lambda (unit)
 316              (www-format-encode-string
 317               (format (if (characterp unit)
 318                           "%c"
 319                         "%s")
 320                       unit)
 321               'without-tags))
 322          (lambda (unit)
 323            (if (characterp unit)
 324                (format "<a href=\"%s?char=%s\">%s</a>"
 325                        chise-wiki-view-url
 326                        (www-uri-encode-char unit)
 327                        (www-format-encode-string (char-to-string unit)))
 328              (www-format-encode-string (format "%s" unit)))))
 329        value " ")
 330     (www-format-encode-string (format "%s" value) without-tags)))
 331
 332 (defun www-format-value-as-ids (value &optional without-tags)
 333   (if (listp value)
 334       (mapconcat
 335        (if without-tags
 336            (lambda (unit)
 337              (www-format-encode-string
 338               (format (if (characterp unit)
 339                           "%c"
 340                         "%s")
 341                       unit)
 342               'without-tags))
 343          (lambda (unit)
 344            (if (characterp unit)
 345                (format "<a href=\"%s?char=%s\">%s</a>"
 346                        chise-wiki-view-url
 347                        (www-uri-encode-char unit)
 348                        (www-format-encode-string (char-to-string unit)))
 349              (www-format-encode-string (format "%s" unit)))))
 350        (ideographic-structure-to-ids value) " ")
 351     (www-format-encode-string (format "%s" value) without-tags)))
 352
 353 (defun www-format-value-as-S-exp (value &optional without-tags)
 354   (www-format-encode-string (format "%S" value) without-tags))
 355
 356 (defun www-format-value-as-HEX (value)
 357   (if (integerp value)
 358       (format "%X" value)
 359     (www-format-value-as-S-exp value)))
 360
 361 (defun www-format-value-as-CCS-default (value)
 362   (if (integerp value)
 363       (format "0x%s (%d)"
 364               (www-format-value-as-HEX value)
 365               value)
 366     (www-format-value-as-S-exp value)))
 367
 368 (defun www-format-value-as-CCS-94x94 (value)
 369   (if (integerp value)
 370       (format "0x%s [%s] (%d)"
 371               (www-format-value-as-HEX value)
 372               (www-format-value-as-kuten value)
 373               value)
 374     (www-format-value-as-S-exp value)))
 375
 376 (defun www-format-value (value &optional feature-name format without-tags)
 377   ;; (cond
 378   ;;  ((find-charset feature-name)
 379   ;;   (cond
 380   ;;    ((and (= (charset-chars feature-name) 94)
 381   ;;          (= (charset-dimension feature-name) 2))
 382   ;;     (www-format-value-as-CCS-94x94 value))
 383   ;;    (t
 384   ;;     (www-format-value-as-CCS-default value)))
 385   ;;   )
 386   ;;  (t
 387   ;;   (www-format-value-as-S-exp value)))
 388   (www-format-apply-value format nil value nil nil without-tags)
 389   )
 390
 391
 392 ;;; @ format evaluator
 393 ;;;
 394
 395 (defun www-format-encode-string (string &optional without-tags)
 396   (with-temp-buffer
 397     (insert string)
 398     (let (plane code start end char variants ret)
 399       (goto-char (point-min))
 400       (while (search-forward "<" nil t)
 401         (replace-match "&lt;" nil t))
 402       (goto-char (point-min))
 403       (while (search-forward ">" nil t)
 404         (replace-match "&gt;" nil t))
 405       (if without-tags
 406           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 407         (let ((coded-charset-entity-reference-alist
 408                (list*
 409                 '(=cns11643-1           "C1-" 4 X)
 410                 '(=cns11643-2           "C2-" 4 X)
 411                 '(=cns11643-3           "C3-" 4 X)
 412                 '(=cns11643-4           "C4-" 4 X)
 413                 '(=cns11643-5           "C5-" 4 X)
 414                 '(=cns11643-6           "C6-" 4 X)
 415                 '(=cns11643-7           "C7-" 4 X)
 416                 '(=gb2312               "G0-" 4 X)
 417                 '(=gb12345              "G1-" 4 X)
 418                 '(=jis-x0208@1990       "J90-" 4 X)
 419                 '(=jis-x0212            "JSP-" 4 X)
 420                 '(=cbeta                "CB" 5 d)
 421                 '(=jis-x0208@1997       "J97-" 4 X)
 422                 '(=jis-x0208@1978       "J78-" 4 X)
 423                 '(=jis-x0208@1983       "J83-" 4 X)
 424                 '(=gt                   "GT-" 5 d)
 425                 '(=zinbun-oracle        "ZOB-" 4 d)
 426                 '(=jef-china3           "JC3-" 4 X)
 427                 '(=daikanwa             "M-" 5 d)
 428                 coded-charset-entity-reference-alist)))
 429           (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 430
 431           (goto-char (point-min))
 432           (while (re-search-forward "&CB\\([0-9]+\\);" nil t)
 433             (setq code (string-to-int (match-string 1)))
 434             (replace-match
 435              (format "<img alt=\"CB%05d\" src=\"%s/cb-gaiji/%02d/CB%05d.gif\">"
 436                      code
 437                      chise-wiki-bitmap-glyphs-url
 438                      (/ code 1000) code)
 439              t 'literal))
 440
 441           (goto-char (point-min))
 442           (while (re-search-forward "&J\\(78\\|83\\|90\\|97\\|SP\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 443             (setq plane (match-string 1)
 444                   code (string-to-int (match-string 2) 16))
 445             (replace-match
 446              (format "<img alt=\"J%s-%04X\" src=\"%s/JIS-%s/%02d-%02d.gif\">"
 447                      plane code
 448                      chise-wiki-bitmap-glyphs-url
 449                      plane
 450                      (- (lsh code -8) 32)
 451                      (- (logand code 255) 32))
 452              t 'literal))
 453
 454           (goto-char (point-min))
 455           (while (re-search-forward "&G\\([01]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 456             (setq plane (string-to-int (match-string 1))
 457                   code (string-to-int (match-string 2) 16))
 458             (replace-match
 459              (format "<img alt=\"GB%d-%04X\" src=\"%s/GB%d/%02d-%02d.gif\">"
 460                      plane code
 461                      chise-wiki-bitmap-glyphs-url
 462                      plane
 463                      (- (lsh code -8) 32)
 464                      (- (logand code 255) 32))
 465              t 'literal))
 466
 467           (goto-char (point-min))
 468           (while (re-search-forward "&C\\([1-7]\\)-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 469             (setq plane (string-to-int (match-string 1))
 470                   code (string-to-int (match-string 2) 16))
 471             (replace-match
 472              (format "<img alt=\"CNS%d-%04X\" src=\"%s/CNS%d/%04X.gif\">"
 473                      plane code
 474                      chise-wiki-bitmap-glyphs-url
 475                      plane code)
 476              t 'literal))
 477
 478           (goto-char (point-min))
 479           (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t)
 480             (setq code (string-to-int (match-string 1) 16))
 481             (replace-match
 482              (format "<img alt=\"JC3-%04X\" src=\"http://kanji.zinbun.kyoto-u.ac.jp/db/CHINA3/Gaiji/%04x.gif\">"
 483                      code code)
 484              t 'literal))
 485
 486           (goto-char (point-min))
 487           (while (re-search-forward "&ZOB-\\([0-9]+\\);" nil t)
 488             (setq code (string-to-int (match-string 1)))
 489             (replace-match
 490              (format "<img alt=\"ZOB-%04d\" src=\"%s/ZOB-1968/%04d.png\">"
 491                      code
 492                      chise-wiki-bitmap-glyphs-url
 493                      code)
 494              t 'literal))
 495
 496           (goto-char (point-min))
 497           (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t)
 498             (setq code (string-to-int (match-string 2)))
 499             (replace-match
 500              (format "<img alt=\"GT-%05d\" src=\"%s?char=GT-%05d\">"
 501                      code
 502                      chise-wiki-glyph-cgi-url
 503                      code)
 504              t 'literal))
 505
 506           (goto-char (point-min))
 507           (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t)
 508             (setq code (string-to-int (match-string 1) 16))
 509             (replace-match
 510              (format "<img alt=\"B-%04X\" src=\"%s?char=B-%04X\">"
 511                      code
 512                      chise-wiki-glyph-cgi-url
 513                      code)
 514              t 'literal))
 515
 516           (goto-char (point-min))
 517           (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t)
 518             (setq code (string-to-int (match-string 1) 16))
 519             (replace-match
 520              (format "<img alt=\"CDP-%04X\" src=\"%s?char=CDP-%04X\">"
 521                      code
 522                      chise-wiki-glyph-cgi-url
 523                      code)
 524              t 'literal))
 525
 526           (goto-char (point-min))
 527           (while (re-search-forward "&UU\\+\\([0-9A-F]+\\);" nil t)
 528             (setq code (string-to-int (match-string 1) 16))
 529             (replace-match
 530              (format "<img alt=\"UU+%04X\" src=\"http://www.unicode.org/cgi-bin/refglyph?24-%04X\">"
 531                      code
 532                      code)
 533              t 'literal))
 534
 535           (goto-char (point-min))
 536           (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t)
 537             (setq code (string-to-int (match-string 1) 16))
 538             (setq start (match-beginning 0)
 539                   end (match-end 0))
 540             (setq char (decode-char 'system-char-id code))
 541             (setq variants (or (www-char-feature char '->subsumptive)
 542                                (www-char-feature char '->denotational)))
 543             (while (and variants
 544                         (setq ret (www-format-encode-string
 545                                    (char-to-string (car variants))))
 546                         (string-match "&MCS-\\([0-9A-F]+\\);" ret))
 547               (setq variants (cdr variants)))
 548             (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret)
 549               (goto-char start)
 550               (delete-region start end)
 551               (insert ret)))
 552           ))
 553       ;; (goto-char (point-min))
 554       ;; (while (search-forward "&GT-" nil t)
 555       ;;   (replace-match "&amp;GT-" t 'literal))
 556       (buffer-string))))
 557
 558 (defun www-format-props-to-string (props &optional format)
 559   (unless format
 560     (setq format (plist-get props :format)))
 561   (concat "%"
 562           (plist-get props :flag)
 563           (if (plist-get props :zero-padding)
 564               "0")
 565           (if (plist-get props :len)
 566               (format "%d" (plist-get props :len)))
 567           (cond
 568            ((eq format 'decimal) "d")
 569            ((eq format 'hex) "x")
 570            ((eq format 'HEX) "X")
 571            ((eq format 'S-exp) "S")
 572            (t "s"))))
 573
 574 (defun www-format-apply-value (format props value
 575                                       &optional uri-char uri-feature
 576                                       without-tags)
 577   (let (ret)
 578     (setq ret
 579           (cond
 580            ((memq format '(decimal hex HEX))
 581             (if (integerp value)
 582                 (format (www-format-props-to-string props format)
 583                         value)
 584               (www-format-encode-string
 585                (format "%s" value)
 586                without-tags))
 587             )
 588            ((eq format 'S-exp)
 589             (www-format-encode-string
 590              (format (www-format-props-to-string props format)
 591                      value)
 592              without-tags))
 593            ((eq format 'ku-ten)
 594             (www-format-value-as-kuten value))
 595            ((eq format 'space-separated-char-list)
 596             (www-format-value-as-char-list value without-tags))
 597            ((eq format 'space-separated-ids)
 598             (www-format-value-as-ids value without-tags))
 599            (t
 600             ;; (setq format 'default)
 601             (www-format-encode-string
 602              (format (www-format-props-to-string props 'default)
 603                      value)
 604              without-tags))))
 605     (if (or without-tags (eq (plist-get props :mode) 'peek))
 606         ret
 607       (format "%s <a href=\"%s?char=%s&feature=%s&format=%s\"
 608 ><input type=\"submit\" value=\"edit\" /></a>"
 609               ret
 610               chise-wiki-edit-url
 611               uri-char uri-feature format))))
 612
 613 (defun www-format-eval-feature-value (char
 614                                       feature-name
 615                                       &optional format lang uri-char value)
 616   (unless value
 617     (setq value (www-char-feature char feature-name)))
 618   (unless format
 619     (setq format (www-feature-value-format feature-name)))
 620   (cond
 621    ((symbolp format)
 622     (www-format-apply-value
 623      format nil value
 624      uri-char (www-uri-encode-feature-name feature-name))
 625     )
 626    ((consp format)
 627     (cond ((null (cdr format))
 628            (setq format (car format))
 629            (www-format-apply-value
 630             (car format) (nth 1 format) value
 631             uri-char (www-uri-encode-feature-name feature-name))
 632            )
 633           (t
 634            (www-format-eval-list format char feature-name lang uri-char)
 635            )))))
 636
 637 (defun www-format-eval-unit (exp char feature-name
 638                                  &optional lang uri-char value)
 639   (unless value
 640     (setq value (www-char-feature char feature-name)))
 641   (unless uri-char
 642     (setq uri-char (www-uri-encode-char char)))
 643   (cond
 644    ((stringp exp) (www-format-encode-string exp))
 645    ((null exp) "")
 646    ((consp exp)
 647     (cond
 648      ((memq (car exp) '(value decimal hex HEX ku-ten S-exp default))
 649       (if (eq (car exp) 'value)
 650           (www-format-eval-feature-value char feature-name
 651                                          (plist-get (nth 1 exp) :format)
 652                                          lang uri-char value)
 653         (www-format-apply-value
 654          (car exp) (nth 1 exp) value
 655          uri-char (www-uri-encode-feature-name feature-name)))
 656       )
 657      ((eq (car exp) 'name)
 658       (format "<a href=\"%s?feature=%s&char=%s\">%s</a>"
 659               chise-wiki-view-url
 660               (www-uri-encode-feature-name feature-name)
 661               uri-char
 662               (www-format-feature-name feature-name lang))
 663       )
 664      ((eq (car exp) 'link)
 665       (format "<a
 666  href=\"%s\"
 667 >%s</a
 668 >"
 669               (www-format-eval-list (plist-get (nth 1 exp) :ref)
 670                                     char feature-name lang uri-char)
 671               (www-format-eval-list (nthcdr 2 exp)
 672                                     char feature-name lang uri-char)))
 673      (t
 674       (format "<%s
 675 >%s</%s
 676 >"
 677               (car exp)
 678               (www-format-eval-list (nthcdr 2 exp) char feature-name
 679                                     lang uri-char)
 680               (car exp)))))))
 681
 682 (defun www-format-eval-list (format-list char feature-name
 683                                          &optional lang uri-char)
 684   (if (consp format-list)
 685       (mapconcat
 686        (lambda (exp)
 687          (www-format-eval-unit exp char feature-name lang uri-char))
 688        format-list "")
 689     (www-format-eval-unit format-list char feature-name lang uri-char)))
 690
 691
 692 ;;; @ HTML generator
 693 ;;;
 694
 695 (defun www-html-display-text (text)
 696   (princ
 697    (with-temp-buffer
 698      (insert text)
 699      (goto-char (point-min))
 700      (while (search-forward "<" nil t)
 701        (replace-match "&lt;" nil t))
 702      (goto-char (point-min))
 703      (while (search-forward ">" nil t)
 704        (replace-match "&gt;" nil t))
 705      (goto-char (point-min))
 706      (while (re-search-forward "\\[\\[\\([^]|[]+\\)|\\([^][]+\\)\\]\\]" nil t)
 707        (replace-match
 708         (format "<a href=\"%s\">%s</a>"
 709                 (match-string 2)
 710                 (match-string 1))
 711         nil t))
 712      (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er)
 713      (goto-char (point-min))
 714      (while (search-forward "&GT-" nil t)
 715        (replace-match "&amp;GT-" nil t))
 716      (buffer-string))))
 717
 718 (defun www-html-display-paragraph (text)
 719   (princ "<p>")
 720   (www-html-display-text text)
 721   (princ "</p>\n"))
 722
 723 (provide 'cwiki-common)