;; -*- coding: utf-8-mcs-er -*-
(defvar chise-wiki-view-url "view.cgi")
(defvar chise-wiki-edit-url "edit.cgi")

(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 ((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-object genre unit))
	  (setq dest (cons char dest))))
    (nreverse dest)))

(defun www-parse-string-as-space-separated-ids (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)
      (let ((ku (string-to-int (match-string 1 string)))
	    (ten (string-to-int (match-string 2 string))))
	(if (and (<= 1 ku)(<= ku 94)
		 (<= 1 ten)(<= ten 94))
	    (+ (lsh (+ ku 32) 8)
	       ten 32)))))

(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 genre))
	((eq format 'space-separated-ids)
	 (www-parse-string-as-space-separated-ids string))
	((eq format 'ku-ten)
	 (www-parse-string-as-ku-ten string))
	((eq format 'decimal)
	 (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 (decode-uri-string string 'utf-8-mcs-er)))
	 )
	(t 
	 (www-parse-string-default string)
	 )))


;;; @ 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 ((object (www-uri-decode-object genre uri-object))
	latest-feature
	logical-feature displayed-features
	ret)
    (when object
      (princ
       (encode-coding-string
	(format "<head>
<title>EsT %s = %s</title>
</head>\n"
		genre
		(decode-uri-string uri-object 'utf-8-mcs-er))
	'utf-8-mcs-er))
      (princ "<body>\n")
      (www-html-display-paragraph
       (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 "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).")
	)
      (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 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, 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)))
    (princ
     (encode-coding-string
      (format "<head>
<title>CHISE-wiki feature: %s</title>
</head>\n"
	      feature-name)
      'utf-8-mcs-er))
    (princ "<body>\n")
    (princ
     (encode-coding-string
      (format "<h1>%s</h1>\n"
	      feature-name)
      'utf-8-mcs-er))
    (princ
     (format "<p>name : %s <a href=\"%s?feature=%s&property=name\"
><input type=\"submit\" value=\"edit\" /></a></p>
"
	     (or (www-format-feature-name feature-name) "")
	     chise-wiki-edit-url
	     ;; (char-feature-property feature-name 'name)
	     uri-feature-name ; (www-uri-encode-feature-name feature-name)
	     ))
    (when lang
      (princ
       (format "<p>%s : %s <a href=\"%s?feature=%s&property=%s\"
><input type=\"submit\" value=\"edit\" /></a></p>
"
	       name@lang
	       (www-format-encode-string
		(or (char-feature-property feature-name name@lang) ""))
	       chise-wiki-edit-url
	       uri-feature-name
	       name@lang)))
    (www-html-display-paragraph
     (format "type : %s"
             (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)
		 "")))
    (when lang
      (www-html-display-paragraph
       (format "description@%s : %s"
	       lang
	       (or (char-feature-property
		    feature-name
		    (intern (format "description@%s" lang)))
		   ""))))
    (princ "<hr />")
    (www-html-display-paragraph
     (format "「[[%c|%s?char=%s]]」に\u623Bる"
	     (www-uri-decode-object 'character uri-object)
	     chise-wiki-view-url
	     uri-object))
    ))

(defun www-batch-set ()
  (setq terminal-coding-system 'binary)
  (condition-case err
      (let* ((target (pop command-line-args-left))
	     (user (pop command-line-args-left))
	     (accept-language (pop command-line-args-left))
	     (lang
	      (intern (car (split-string
			    (car (split-string
				  (car (split-string accept-language ","))
				  ";"))
			    "-"))))
	     ret name val prop)
	(princ "Content-Type: text/html; charset=UTF-8

<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
            \"http://www.w3.org/TR/html4/loose.dtd\">
<html lang=\"ja\">
")
	(setq target
	      (mapcar (lambda (cell)
			(if (string-match "=" cell)
			    (progn
			      (setq name (substring
					  cell 0 (match-beginning 0))
				    val (substring cell (match-end 0)))
			      (cons
			       (intern
				(decode-uri-string name 'utf-8-mcs-er))
			       val))
			  (list (decode-uri-string cell 'utf-8-mcs-er))))
		      (split-string target "&")))
	(setq ret (car target))
	(cond ((eq (car ret) 'char)
	       (setq prop (nth 2 target))
	       (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 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)
		lang
                (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 "\n<hr>\n")
	(princ (format "user=%s\n" user))
	(princ (format "local user=%s\n" (user-login-name)))
	(princ (format "lang=%S\n" lang))
	(princ emacs-version)
	(princ " CHISE ")
	(princ (encode-coding-string xemacs-chise-version 'utf-8-jp-er))
	(princ "
</body>
</html>")
	)
    (error nil
	   (princ (format "%S" err)))
    ))