From ca7ce77367a8e5e76525da5ebe18582c32840ff7 Mon Sep 17 00:00:00 2001 From: MORIOKA Tomohiko Date: Sun, 23 Sep 2012 14:04:04 +0900 Subject: [PATCH] New file. --- est-rdf-view.el | 333 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 333 insertions(+) create mode 100644 est-rdf-view.el diff --git a/est-rdf-view.el b/est-rdf-view.el new file mode 100644 index 0000000..6a7d225 --- /dev/null +++ b/est-rdf-view.el @@ -0,0 +1,333 @@ +;; -*- coding: utf-8-mcs-er -*- +(require 'cwiki-format) + +(defvar chise-wiki-view-url "view.cgi") +(defvar chise-wiki-edit-url "edit.cgi") +(defvar chise-wiki-add-url "add.cgi") + +(defun est-rdf-encode-feature-name (feature-name) + (let ((str (symbol-name feature-name)) + base domain + ret) + (if (string-match "@" str) + (setq base (substring str 0 (match-beginning 0)) + domain (substring str (match-end 0))) + (setq base str)) + (setq ret (mapconcat (lambda (c) + (cond ((eq c ?*) + ".") + ((eq c ?/) + "-") + (t (char-to-string c)))) + base "")) + (if (eq (aref ret 0) ?.) + (setq ret (concat "meta" ret))) + (cons (if domain + (concat "est." + (mapconcat #'identity + (split-string domain "/") + ".")) + "est") + (www-uri-encode-feature-name (intern ret))))) + +(defun est-rdf-format-object (obj) + (if (or (characterp obj) + (concord-object-p obj)) + (let ((genre (est-object-genre obj)) + (url-object (www-uri-encode-object obj))) + (format " + + " + genre url-object)) + (encode-coding-string (format " + %s" obj) + 'utf-8-mcs-er))) + +(defun est-rdf-format-object-list (obj-list &optional with-li) + ;; (concat (mapconcat #'est-rdf-format-object + ;; obj-list + ;; "") + ;; "\n") + (let ((rest obj-list) + dest obj) + (while (consp rest) + (setq obj (pop rest)) + (if with-li + (setq dest (concat dest + " + " + (est-rdf-format-object obj) + " + ")) + (setq dest (concat dest (est-rdf-format-object obj))))) + (if rest + (setq dest (concat dest (est-rdf-format-object rest)))) + (concat dest "\n "))) + +(defun est-rdf-display-object-desc (genre uri-object &optional lang level) + (unless level + (setq level 0)) + (let ((object (www-uri-decode-object genre uri-object)) + logical-feature chise-wiki-displayed-features + object-spec + rdf-feature-name rdf-feature-name-space + feature-type rdf-container + value ret) + (if (eq level 0) + (setq level 1)) + (when object + (when (and (eq genre 'character) + (= (length uri-object) 1)) + (setq uri-object (www-uri-encode-object object))) + (when (eq genre 'character) + (dolist (feature (char-feature-property '$object 'additional-features)) + (mount-char-attribute-table + (char-feature-name-at-domain feature '$rev=latest)))) + (setq object-spec + (if (eq genre 'character) + (char-attribute-alist object) + (concord-object-spec object))) + (princ + (format "\n" + genre uri-object)) + (dolist (cell (sort object-spec + (lambda (a b) + (char-attribute-name< + (char-feature-name-sans-versions (car a)) + (char-feature-name-sans-versions (car b)))))) + (setq logical-feature (char-feature-name-sans-versions (car cell))) + (unless (memq logical-feature chise-wiki-displayed-features) + (push logical-feature chise-wiki-displayed-features) + (setq value (www-get-feature-value object logical-feature)) + (setq ret (est-rdf-encode-feature-name logical-feature)) + (setq rdf-feature-name (format "%s:%s" (car ret)(cdr ret))) + (setq rdf-feature-name-space + (format "xmlns:%s=\"http://www.chise.org/est/rdf.cgi?domain=%s/\"" + (car ret) + (car ret))) + (setq feature-type (www-feature-type logical-feature)) + (if (and (consp value) + (cdr value)) + (cond + ((eq feature-type 'structure) + (setq rdf-container "rdf:Seq") + ) + ;; ((eq feature-type 'relation) + ;; (setq rdf-container "rdf:Bag") + ;; ) + (t + (setq rdf-container "rdf:Bag") + )) + (setq rdf-container nil)) + (princ + (format " <%s\n %s>%s%s%s\n" + rdf-feature-name + rdf-feature-name-space + (if rdf-container + (format "\n <%s>" rdf-container) + "") + (est-rdf-format-object-list value rdf-container) + (if rdf-container + (format "\n " rdf-container) + "") + rdf-feature-name)) + )) + (princ "") + ))) + +(defun est-rdf-display-feature-desc (uri-feature-name genre uri-object + &optional lang simple) + (let ((feature-name (www-uri-decode-feature-name uri-feature-name)) + (name@lang (intern (format "name@%s" lang)))) + (princ + (encode-coding-string + (format " +EsT feature: %s +\n" + feature-name) + 'utf-8-mcs-er)) + (princ "\n") + (princ + (format + (if simple + "
+ + + + +
+
\n" + "
+ + + +
+
\n") + uri-feature-name genre uri-object)) + (princ + (format "

%s

\n" + (www-format-encode-string + (symbol-name feature-name)))) + (princ (format "

name : %s " + (or (www-format-feature-name feature-name) ""))) + (unless simple + (princ + (format + " " + chise-wiki-edit-url + uri-feature-name + genre + uri-object)) + (princ "\n")) + (princ "

\n") + (when lang + (princ "

") + (princ + (www-format-encode-string + (format "%s : %s" + name@lang + (or (char-feature-property feature-name name@lang) "")))) + (unless simple + (princ + (format + " " + chise-wiki-edit-url + uri-feature-name + name@lang + genre + uri-object)) + (princ "\n")) + (princ "

\n")) + (www-html-display-paragraph + (format "type : %s" + (or (www-feature-type feature-name) + ;; (char-feature-property feature-name 'type) + 'generic))) + (princ (format "

value-format : %s " + (www-format-value + nil 'value-format + (or (www-feature-value-format feature-name) + 'default) + 'default + 'without-tags) + )) + (unless simple + (princ + (format + " " + chise-wiki-edit-url + uri-feature-name + genre + uri-object)) + (princ "\n")) + (princ "

\n") + + (princ "

format : ") + (www-html-display-text + (decode-coding-string + (www-xml-format-list + (www-feature-format feature-name)) + 'utf-8-mcs-er)) + (unless simple + (princ + (format + " " + chise-wiki-edit-url + uri-feature-name + genre + uri-object)) + (princ "\n")) + (princ "

\n") + + (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))) + "")))) + )) + +(defun est-rdf-batch-view () + (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)) + (mode (intern (pop command-line-args-left))) + (lang + (intern + (car (split-string + (car (split-string + (car (split-string accept-language ",")) + ";")) + "-")))) + ret genre) + (princ "Content-Type: application/xml + + + +") + (cond + ((stringp target) + (when (string-match "^char=\\(&[^&;]+;\\)" target) + (setq ret (match-end 0)) + (setq target + (concat "char=" + (www-uri-encode-object + (www-uri-decode-object + 'character (match-string 1 target))) + (substring target ret)))) + (setq target + (mapcar (lambda (cell) + (if (string-match "=" cell) + (progn + (setq genre (substring cell 0 (match-beginning 0)) + ret (substring cell (match-end 0))) + (cons + (intern + (decode-uri-string genre 'utf-8-mcs-er)) + ret)) + (list (decode-uri-string cell 'utf-8-mcs-er)))) + (split-string target "&"))) + (setq ret (car target)) + (cond ((eq (car ret) 'char) + (est-rdf-display-object-desc + 'character + (cdr ret) + lang nil) + ) + ((eq (car ret) 'feature) + (est-rdf-display-feature-desc + (decode-uri-string (cdr ret) 'utf-8-mcs-er) + (car (nth 1 target)) + (cdr (nth 1 target)) + lang + (eq mode 'simple)) + ) + (t + (est-rdf-display-object-desc + (car ret) + (cdr ret) + lang nil) + )) + )) + (princ " +") + ) + (error nil + (princ (format "%S" err))) + )) + +(provide 'cwiki-view) -- 1.7.10.4