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