X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fest.git;a=blobdiff_plain;f=cwiki-set.el;h=c268068b63c303f38e22f319dc7e8fb578606e53;hp=0429584ddacb101b2b4bb61a581e1ffb1ad51e31;hb=HEAD;hpb=26f5224a5e9b4b1e8cc60c3f3ffa9ef8e255611b

diff --git a/cwiki-set.el b/cwiki-set.el
index 0429584..c268068 100644
--- a/cwiki-set.el
+++ b/cwiki-set.el
@@ -1,25 +1,105 @@
 ;; -*- coding: utf-8-mcs-er -*-
-(defvar chise-wiki-view-url "../view.cgi")
+(defvar chise-wiki-view-url "view.cgi")
 (defvar chise-wiki-edit-url "edit.cgi")
 
-(require 'cwiki-common)
 (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 (www-xml-to-stext-props (nth 1 unit))
+	      children (nthcdr 2 unit))
+	(if children
+	    (setq children (www-xml-to-stext-list children)))
+	(when (and (eq name 'link)
+		   (consp (car children))
+		   (eq (caar children) 'ref))
+	  (setq props (list* :ref (nthcdr 2 (car children))
+			     props)
+		children (cdr children)))
+	(if children
+	    (list* name props children)
+	  (if props
+	      (list name 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
-      (let ((ret
-	     (mapcar #'read (split-string string " "))))
-	(if (cdr ret)
-	    ret
-	  (car ret)))
+      ;; (let ((ret
+      ;;        (mapcar #'read (split-string string " "))))
+      ;;   (if (cdr ret)
+      ;;       ret
+      ;;     (car ret)))
+      (let ((i 0)
+	    (len (length string))
+	    dest ret)
+	(while (< i len)
+	  (setq ret (read-from-string string i))
+	  (setq dest (cons (car ret) dest)
+		i (cdr ret)))
+	(if (cdr dest)
+	    (nreverse dest)
+	  (if (atom (car dest))
+	      (car dest)
+	    (nreverse dest))))
     (error nil)))
 
-(defun www-parse-string-as-space-separated-char-list (string)
+(defun www-parse-string-as-space-separated-char-list (string genre)
   (let (dest char)
     (dolist (unit (split-string string "\\+"))
-      (if (setq char (www-uri-decode-char unit))
+      (if (setq char (www-uri-decode-object genre unit))
 	  (setq dest (cons char dest))))
     (nreverse dest)))
 
@@ -29,7 +109,7 @@
     (let (char)
       (mapconcat
        (lambda (unit)
-	 (if (setq char (www-uri-decode-char unit))
+	 (if (setq char (www-uri-decode-object 'character unit))
 	     (char-to-string char)
 	   unit))
        (split-string string "\\+")
@@ -44,11 +124,38 @@
 	    (+ (lsh (+ ku 32) 8)
 	       ten 32)))))
 
-(defun www-feature-parse-string (feature-name string &optional format)
+(defun www-parse-string-as-kangxi-radical (string)
+  (setq string (decode-uri-string string 'utf-8-mcs-er))
+  (let ((i 0)
+	(len (length string))
+	char ret)
+    (while (and (< i len)
+		(setq char (aref string i))
+		(not
+		 (and (setq ret (char-ucs char))
+		      (<= #x2F00 ret)
+		      (<= ret #x2FD5)))
+		(not (setq ret (char-feature char '->radical))))
+      (setq i (1+ i)))
+    (if (integerp ret)
+	(- ret #x2EFF)
+      (and (setq ret (car ret))
+	   (setq ret (char-ucs ret))
+	   (<= #x2F00 ret)
+	   (<= ret #x2FD5)
+	   (- ret #x2EFF)))))
+
+(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 (genre feature-name string &optional format)
   (unless format
     (setq format (www-feature-value-format feature-name)))
   (cond ((eq format 'space-separated-char-list)
-	 (www-parse-string-as-space-separated-char-list string))
+	 (www-parse-string-as-space-separated-char-list string genre))
 	((eq format 'space-separated-ids)
 	 (www-parse-string-as-space-separated-ids string))
 	((eq format 'ku-ten)
@@ -60,6 +167,11 @@
 	((eq format 'string)
 	 (decode-uri-string string 'utf-8-mcs-er)
 	 )
+	((eq format 'kangxi-radical)
+	 (www-parse-string-as-kangxi-radical string))
+	((eq format 'wiki-text)
+	 (www-parse-string-as-wiki-text string)
+	 )
 	((eq format 'S-exp)
 	 (if (= (length string) 0)
 	     nil
@@ -69,87 +181,110 @@
 	 (www-parse-string-default string)
 	 )))
 
-(defun www-set-display-char-desc (uri-char feature value format &optional lang)
+
+;;; @ display
+;;;
+
+(defun www-set-display-object-desc (genre uri-object feature value format
+					  &optional lang)
   (when (stringp feature)
     (setq feature (intern feature)))
   (when (stringp format)
     (setq format (intern format)))
-  (let ((char (www-uri-decode-char uri-char))
+  (let ((object (www-uri-decode-object genre uri-object))
 	latest-feature
-	feature-name logical-feature displayed-features)
-    (when (characterp char)
+	logical-feature displayed-features
+	ret)
+    (when object
       (princ
        (encode-coding-string
 	(format "<head>
-<title>CHISE-wiki character: %s</title>
+<title>EsT %s = %s</title>
 </head>\n"
-		(decode-uri-string uri-char 'utf-8-mcs-er))
+		genre
+		(decode-uri-string uri-object 'utf-8-mcs-er))
 	'utf-8-mcs-er))
       (princ "<body>\n")
       (www-html-display-paragraph
-       (format "char: %S %S %S %S\n"
-	       uri-char feature value lang))
-      (setq value (www-feature-parse-string feature value format))
+       (format "object: %S (%S) %S %S %S\n"
+	       uri-object genre feature value lang))
+      (setq value (www-feature-parse-string genre feature value format))
       (www-html-display-paragraph
-       (format "char = %c : %S \u2190 %S"
-	       char feature value))
+       (format "object = %s (%s) : %S \u2190 %S"
+	       (est-format-object object) genre feature value))
       (setq latest-feature
 	    (char-feature-name-at-domain feature '$rev=latest))
       (if value
-	  (if (equal (www-char-feature char feature) value)
+	  (if (equal (www-get-feature-value object 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)))
-	    (put-char-attribute char latest-feature value)
-	    (save-char-attribute-table latest-feature)
+            ;; (www-html-display-paragraph
+            ;;  (format "New feature-value = %S is different from old value %S"
+            ;;          value
+            ;;          (www-get-feature-value object feature)))
+	    (cond
+	     ((characterp object)
+	      (put-char-attribute object 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)))
+	      )
+	     (t
+	      (concord-object-put object latest-feature value)
+	      ))
 	    )
 	(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 (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)))
-	(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)
-		'((name) " : " (value)))
-	    char (car cell) lang uri-char))
-	  (princ
-	   (format " <a href=\"%s?char=%s&feature=%s\"
-><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)))))))
-	  (princ "</p>\n")
-	  ))
-      (princ
-       (format "<p><a href=\"%s?char=%s\"
-><input type=\"submit\" value=\"add feature\" /></a></p>"
-	       chise-wiki-add-url
-	       (www-format-encode-string uri-char)))
+      (www-display-object-desc genre uri-object nil lang 1)
+      ;; (princ (format "<h1>%s</h1>\n"
+      ;;                (www-format-encode-string (char-to-string object))))
+      ;; (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 object)
+      ;;                     (lambda (a b)
+      ;;                       (char-attribute-name< (car a)(car b)))))
+      ;;   (setq logical-feature
+      ;;         (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 logical-feature 'format)
+      ;;           '((name) " : " (value)))
+      ;;       object logical-feature lang uri-object))
+      ;;     (princ
+      ;;      (format " <a href=\"%s?char=%s&feature=%s&format=wiki-text\"
+;;><inpu;; t type=\"submit\" value=\"note\" /></a>"
+      ;;              chise-wiki-edit-url
+      ;;              (www-format-encode-string uri-object)
+      ;;              (www-format-encode-string
+      ;;               (www-uri-encode-feature-name
+      ;;                (intern (format "%s*note" logical-feature))))))
+      ;;     (princ "</p>\n")
+      ;;     ))
+      ;; (princ
+      ;;  (format "<p><a href=\"%s?char=%s\"
+;;><inpu;; t type=\"submit\" value=\"add feature\" /></a></p>"
+      ;;          chise-wiki-add-url
+      ;;          (www-format-encode-string uri-object)))
       )))
 
-(defun www-set-display-feature-desc (feature-name property-name value
-						  &optional lang uri-char)
+(defun www-set-display-feature-desc (feature-name property-name value format
+						  &optional lang uri-object)
+  (www-html-display-paragraph
+   (format
+    "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, object: %S\n"
+    feature-name property-name format value lang uri-object))
+  (setq value (www-feature-parse-string 'feature property-name value format))
   (www-html-display-paragraph
    (format
-    "set: feature: %S, property-name: %S, value: %S, lang: %S, char: %S\n"
-    feature-name property-name value lang uri-char))
+    "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, object: %S\n"
+    feature-name property-name format value lang uri-object))
   (put-char-feature-property feature-name property-name value)
   (let ((name@lang (intern (format "name@%s" lang)))
 	(uri-feature-name (www-uri-encode-feature-name feature-name)))
@@ -191,6 +326,20 @@
              (or (www-feature-type feature-name)
 		 ;; (char-feature-property feature-name 'type)
 		 'generic)))
+    (princ (format "<p>value-format : %s "
+		   (www-format-value
+		    nil 'value-format 
+		    (or (www-feature-value-format feature-name)
+			'default)
+		    'default
+		    'without-tags)))
+    (princ
+     (format
+      " <a href=\"%s?feature=%s&property=value-format&format=wiki-text&char=%s\"
+><input type=\"submit\" value=\"edit\" /></a></p>"
+      chise-wiki-edit-url
+      uri-feature-name
+      uri-object))
     (www-html-display-paragraph
      (format "description : %s"
              (or (char-feature-property feature-name 'description)
@@ -205,8 +354,10 @@
 		   ""))))
     (princ "<hr />")
     (www-html-display-paragraph
-     (format "「[[%c|../view.cgi?char=%s]]」に\u623Bる"
-	     (www-uri-decode-char uri-char) uri-char))
+     (format "「[[%c|%s?char=%s]]」に\u623Bる"
+	     (www-uri-decode-object 'character uri-object)
+	     chise-wiki-view-url
+	     uri-object))
     ))
 
 (defun www-batch-set ()
@@ -244,7 +395,8 @@
 	(setq ret (car target))
 	(cond ((eq (car ret) 'char)
 	       (setq prop (nth 2 target))
-	       (www-set-display-char-desc
+	       (www-set-display-object-desc
+		'character
 		(cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
 		(intern (decode-uri-string
 			 (cdr (assq 'feature-name target))
@@ -254,15 +406,29 @@
                 lang)
 	       )
 	      ((eq (car ret) 'feature)
-	       (setq prop (nth 2 target))
+	       (setq prop (nth 3 target))
 	       (www-set-display-feature-desc
 		(intern (decode-uri-string (cdr ret) 'utf-8-mcs-er))
+                (intern (decode-uri-string
+			 (cdr (assq 'feature-name (cdr target)))
+			 'utf-8-mcs-er))
+		(cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
 		(car prop)
-		(decode-uri-string (cdr prop) 'utf-8-mcs-er)
 		lang
                 (cdr (assq 'char target))
-		;; (decode-uri-string (cdr (assq 'char target)))
 		)
+	       )
+	      (t
+	       (setq prop (nth 2 target))
+	       (www-set-display-object-desc
+		(car ret)
+		(cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
+		(intern (decode-uri-string
+			 (cdr (assq 'feature-name target))
+			 'utf-8-mcs-er))
+                (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
+		(car prop)
+                lang)
 	       ))
 	(www-html-display-paragraph
 	 (format "%S" target))
@@ -272,7 +438,7 @@
 	(princ (format "lang=%S\n" lang))
 	(princ emacs-version)
 	(princ " CHISE ")
-	(princ xemacs-chise-version)
+	(princ (encode-coding-string xemacs-chise-version 'utf-8-jp-er))
 	(princ "
 </body>
 </html>")