;; -*- 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)
-(defun www-parse-string-as-space-separated-char-list (string)
+;;; @ 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 ((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 genre)
(let (dest char)
- (dolist (unit (split-string string " "))
- (if (setq char (www-uri-decode-char unit))
+ (dolist (unit (split-string string "\\+"))
+ (if (setq char (www-uri-decode-object genre unit))
(setq dest (cons char dest))))
(nreverse dest)))
(defun www-parse-string-as-space-separated-ids (string)
- (ids-parse-string
- (let (char)
- (mapconcat
- (lambda (unit)
- (if (setq char (www-uri-decode-char unit))
- (char-to-string char)
- unit))
- (split-string string " ")
- ""))))
+ (cdar
+ (ids-parse-string
+ (let (char)
+ (mapconcat
+ (lambda (unit)
+ (if (setq char (www-uri-decode-object 'character unit))
+ (char-to-string char)
+ unit))
+ (split-string string "\\+")
+ "")))))
(defun www-parse-string-as-ku-ten (string)
(if (string-match "^\\([0-9][0-9]?\\)-\\([0-9][0-9]?\\)" string)
(+ (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)
(string-to-number string))
((or (eq format 'HEX)(eq format 'hex))
(string-to-number string 16))
+ ((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
- (read string)))
- (t string)))
+ (read (decode-uri-string string 'utf-8-mcs-er)))
+ )
+ (t
+ (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)))
- (when (characterp char)
+ (let ((object (www-uri-decode-object genre uri-object))
+ latest-feature
+ 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"
- uri-char)
+ 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))
- (www-html-display-paragraph
- (format "char = %c" char))
- (www-html-display-paragraph
- (format "feature-name = %S" feature))
+ (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 "feature-value = %S" value))
- (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)))))
- (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")
+ (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-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-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 "<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\n"
- feature-name property-name value lang))
+ (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))
(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)))
><input type=\"submit\" value=\"edit\" /></a></p>
"
name@lang
- (or (www-format-encode-string
- (char-feature-property feature-name name@lang)) "")
+ (www-format-encode-string
+ (or (char-feature-property feature-name name@lang) ""))
chise-wiki-edit-url
uri-feature-name
name@lang)))
(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)
""))))
(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 ()
(setq ret (car target))
(cond ((eq (car ret) 'char)
(setq prop (nth 2 target))
- (www-set-display-char-desc
- (decode-uri-string (cdr ret) 'utf-8-mcs-er)
- (cdr (assq 'feature-name target))
- (decode-uri-string (cdr prop) 'utf-8-mcs-er)
+ (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))
+ 'utf-8-mcs-er))
+ (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
(car prop)
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
- (decode-uri-string (cdr (assq 'char target))))
+ (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))
(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>")
projects / chise / est.git / blobdiff