(www-format-feature-name-as-metadata): New function.

[chise/est.git] / cwiki-set.el

diff --git a/cwiki-set.el b/cwiki-set.el
index 0429584..2b552c3 100644 (file)
--- a/cwiki-set.el
+++ b/cwiki-set.el
@@ -6,6 +6,71 @@
 (require 'cwiki-view)
 
 
+;;; @ stext parser
+;;;
+
+(defun www-xml-parse-string (string)
+  (require 'xml)
+  (nthcdr
+   2
+   (car
+    (with-temp-buffer
+      (insert "<top>")
+      (insert string)
+      (insert "</top>")
+      (xml-parse-region (point-min)(point-max))))))
+
+(defun www-xml-to-stext-props (props)
+  (let (dest)
+    (dolist (cell props)
+      (setq dest (cons (cdr cell)
+                      (cons (intern (format ":%s" (car cell)))
+                            dest))))
+    (nreverse dest)))
+
+(defun www-xml-to-stext-unit (unit)
+  (let (name props children)
+    (cond
+     ((stringp unit)
+      unit)
+     ((consp unit)
+      (setq name (car unit))
+      (if (stringp name)
+         nil
+       (setq props (nth 1 unit)
+             children (nthcdr 2 unit))
+       (if children
+           (setq children (www-xml-to-stext-list children)))
+       (if children
+           (list* name
+                  (www-xml-to-stext-props props)
+                  children)
+         (if props
+             (list name (www-xml-to-stext-props props))
+           (list name))))
+      )
+     (t
+      (format "%S" unit)))))
+
+(defun www-xml-to-stext-list (trees)
+  (cond
+   ((atom trees)
+    (www-xml-to-stext-unit trees)
+    )
+   ((equal trees '(("")))
+    nil)
+   (t
+    (mapcar #'www-xml-to-stext-unit
+           trees))))
+
+(defun www-stext-parse-xml-string (string)
+  (www-xml-to-stext-list
+   (www-xml-parse-string string)))
+
+
+;;; @ parser
+;;;
+
 (defun www-parse-string-default (string)
   (setq string (decode-uri-string string 'utf-8-mcs-er))
   (condition-case nil
@@ -44,6 +109,12 @@
            (+ (lsh (+ ku 32) 8)
               ten 32)))))
 
+(defun www-parse-string-as-wiki-text (string)
+  (www-stext-parse-xml-string
+   (decode-uri-string string 'utf-8-mcs-er))
+  ;; (list (decode-uri-string string 'utf-8-mcs-er))
+  )
+
 (defun www-feature-parse-string (feature-name string &optional format)
   (unless format
     (setq format (www-feature-value-format feature-name)))
@@ -60,6 +131,9 @@
        ((eq format 'string)
         (decode-uri-string string 'utf-8-mcs-er)
         )
+       ((eq format 'wiki-text)
+        (www-parse-string-as-wiki-text string)
+        )
        ((eq format 'S-exp)
         (if (= (length string) 0)
             nil
@@ -69,6 +143,10 @@
         (www-parse-string-default string)
         )))
 
+
+;;; @ display
+;;;
+
 (defun www-set-display-char-desc (uri-char feature value format &optional lang)
   (when (stringp feature)
     (setq feature (intern feature)))
@@ -76,7 +154,8 @@
     (setq format (intern format)))
   (let ((char (www-uri-decode-char uri-char))
        latest-feature
-       feature-name logical-feature displayed-features)
+       logical-feature displayed-features
+       ret)
     (when (characterp char)
       (princ
        (encode-coding-string
@@ -99,42 +178,46 @@
          (if (equal (www-char-feature char feature) value)
              (www-html-display-paragraph
               "Feature-value is not changed.")
-           (www-html-display-paragraph
-            (format "New feature-value = %S is different from old value %S"
-                    value
-                    (www-char-feature char feature)))
+            ;; (www-html-display-paragraph
+            ;;  (format "New feature-value = %S is different from old value %S"
+            ;;          value
+            ;;          (www-char-feature char feature)))
            (put-char-attribute char latest-feature value)
            (save-char-attribute-table latest-feature)
+           (setq ret (char-feature-property '$object 'additional-features))
+           (unless (memq feature ret)
+             (put-char-feature-property
+              '$object 'additional-features (cons feature ret)))
            )
        (www-html-display-paragraph
         "New feature-value is nil, so it is ignored (may be syntax error).")
        )
       (princ (format "<h1>%s</h1>\n"
                     (www-format-encode-string (char-to-string char))))
+      (dolist (feature (char-feature-property '$object 'additional-features))
+       (mount-char-attribute-table
+        (char-feature-name-at-domain feature '$rev=latest)))
       (dolist (cell (sort (char-attribute-alist char)
                          (lambda (a b)
                            (char-attribute-name< (car a)(car b)))))
-       (setq feature-name (symbol-name (car cell)))
        (setq logical-feature
-             (if (string-match "[@/]\\$rev=latest$" feature-name)
-                 (intern (substring feature-name 0 (match-beginning 0)))
-               (car cell)))
+             (char-feature-name-sans-versions (car cell)))
        (unless (memq logical-feature displayed-features)
          (push logical-feature displayed-features)
          (princ "<p>")
          (princ
           (www-format-eval-list
-           (or (char-feature-property (car cell) 'format)
+           (or (char-feature-property logical-feature 'format)
                '((name) " : " (value)))
-           char (car cell) lang uri-char))
+           char logical-feature lang uri-char))
          (princ
-          (format " <a href=\"%s?char=%s&feature=%s\"
+          (format " <a href=\"%s?char=%s&feature=%s&format=wiki-text\"
 ><input type=\"submit\" value=\"note\" /></a>"
                   chise-wiki-edit-url
                   (www-format-encode-string uri-char)
                   (www-format-encode-string
                    (www-uri-encode-feature-name
-                    (intern (format "%s*note" (car cell)))))))
+                    (intern (format "%s*note" logical-feature))))))
          (princ "</p>\n")
          ))
       (princ