X-Git-Url: http://git.chise.org/gitweb/?p=chise%2Fest.git;a=blobdiff_plain;f=cwiki-common.el;h=4a30be902cfef53d12c30ff2f4743f6ac3f33936;hp=8ef14b766d1248b3a0049c141dd44853a786f8f6;hb=3ab471278b0c4650a83ffa301bd7396bacaf4aed;hpb=90bbce1c07115156afb38bfcb8060979fa94e80f diff --git a/cwiki-common.el b/cwiki-common.el index 8ef14b7..4a30be9 100644 --- a/cwiki-common.el +++ b/cwiki-common.el @@ -4,8 +4,11 @@ (defvar chise-wiki-view-url "view.cgi") (defvar chise-wiki-edit-url "edit/edit.cgi") -(defvar chise-wiki-glyphs-url - "http://chise.zinbun.kyoto-u.ac.jp/glyphs/") +(defvar chise-wiki-bitmap-glyphs-url + "http://chise.zinbun.kyoto-u.ac.jp/glyphs") + +(defvar chise-wiki-glyph-cgi-url + "http://chise.zinbun.kyoto-u.ac.jp/chisewiki/glyph.cgi") (defun decode-uri-string (string &optional coding-system) (if (> (length string) 0) @@ -32,6 +35,12 @@ (or (char-feature-property feature-name 'type) (let ((str (symbol-name feature-name))) (cond + ((string-match "\\*note\\(@[^*]+\\)?$" str) + 'stext) + ((string-match "\\*sources\\(@[^*]+\\)?$" str) + 'domain-list) + ((string-match "\\*" str) + nil) ((string-match "^\\(->\\|<-\\)" str) 'relation) ((string-match "^ideographic-structure\\(@\\|$\\)" str) @@ -44,7 +53,10 @@ (cond ((eq type 'relation) 'space-separated-char-list) ((eq type 'structure) - 'space-separated-ids))) + 'space-separated-ids) + ((eq type 'stext) + 'wiki-text) + )) (if (find-charset feature-name) (if (and (= (charset-dimension feature-name) 2) (= (charset-chars feature-name) 94)) @@ -52,6 +64,28 @@ " (" (decimal) ") <" (ku-ten) ">") '("0x" (HEX) " (" (decimal) ")"))))) +(defun char-feature-name-at-domain (feature-name domain) + (let ((name (symbol-name feature-name))) + (cond + ((string-match "@[^*]+$" name) + (intern (format "%s/%s" name domain)) + ) + (t + (intern (format "%s@%s" name domain)) + )))) + +(defun char-feature-name-sans-versions (feature) + (let ((feature-name (symbol-name feature))) + (if (string-match "[@/]\\$rev=latest$" feature-name) + (intern (substring feature-name 0 (match-beginning 0))) + feature))) + +(defun www-char-feature (character feature) + (let ((latest-feature (char-feature-name-at-domain feature '$rev=latest))) + (mount-char-attribute-table latest-feature) + (or (char-feature character latest-feature) + (char-feature character feature)))) + ;;; @ URI representation ;;; @@ -141,7 +175,7 @@ (defun www-uri-decode-char (char-rep) (let (ccs cpos) (cond - ((string-match "%3A" char-rep) + ((string-match "\\(%3A\\|:\\)" char-rep) (setq ccs (substring char-rep 0 (match-beginning 0)) cpos (substring char-rep (match-end 0))) (setq ccs (www-uri-decode-feature-name ccs)) @@ -181,10 +215,11 @@ =zinbun-oracle =daikanwa =gt =gt-k - =big5 - =big5-cdp =>>jis-x0208 =>>jis-x0213-1 - =>jis-x0208 =>jis-x0213-1)) + =>jis-x0208 =>jis-x0213-1 + =>>gt + =big5 + =big5-cdp)) ccs ret) (while (and ccs-list (setq ccs (pop ccs-list)) @@ -193,10 +228,15 @@ (format "%s:0x%X" (www-uri-encode-feature-name ccs) ret)) - ((setq ccs (car (split-char char))) + ((and (setq ccs (car (split-char char))) + (setq ret (encode-char char ccs))) (format "%s:0x%X" (www-uri-encode-feature-name ccs) - (encode-char char ccs))))))) + ret)) + (t + (format "system-char-id:0x%X" + (encode-char char 'system-char-id)) + ))))) ;;; @ Feature name presentation @@ -210,6 +250,19 @@ "-") " ")) +(defun www-format-feature-name-as-metadata (feature-name &optional lang) + (let ((str (symbol-name feature-name)) + base meta) + (cond + ((string-match "\\*[^*]+$" str) + (setq base (substring str 0 (match-beginning 0)) + meta (substring str (match-beginning 0))) + (concat (www-format-feature-name* (intern base) lang) + meta)) + (t + (www-format-feature-name-default feature-name) + )))) + (defun www-format-feature-name-as-rel-to (feature-name) (concat "\u2192" (substring (symbol-name feature-name) 2))) @@ -236,25 +289,30 @@ ) (t dest)))) -(defun www-format-feature-name (feature-name &optional lang) +(defun www-format-feature-name* (feature-name &optional lang) (let (name) - (www-format-encode-string - (cond - ((or (and lang - (char-feature-property - feature-name - (intern (format "name@%s" lang)))) - (char-feature-property - feature-name 'name))) - ((find-charset feature-name) - (www-format-feature-name-as-CCS feature-name)) - ((and (setq name (symbol-name feature-name)) - (string-match "^\\(->\\)" name)) - (www-format-feature-name-as-rel-to feature-name)) - ((string-match "^\\(<-\\)" name) - (www-format-feature-name-as-rel-from feature-name)) - (t - (www-format-feature-name-default feature-name)))))) + (cond + ((or (and lang + (char-feature-property + feature-name + (intern (format "name@%s" lang)))) + (char-feature-property + feature-name 'name))) + ((find-charset feature-name) + (www-format-feature-name-as-CCS feature-name)) + ((and (setq name (symbol-name feature-name)) + (string-match "\\*" name)) + (www-format-feature-name-as-metadata feature-name lang)) + ((string-match "^\\(->\\)" name) + (www-format-feature-name-as-rel-to feature-name)) + ((string-match "^\\(<-\\)" name) + (www-format-feature-name-as-rel-from feature-name)) + (t + (www-format-feature-name-default feature-name))))) + +(defun www-format-feature-name (feature-name &optional lang) + (www-format-encode-string + (www-format-feature-name* feature-name lang))) ;;; @ Feature value presentation @@ -330,19 +388,12 @@ value) (www-format-value-as-S-exp value))) -(defun www-format-value (value &optional feature-name format without-tags) - ;; (cond - ;; ((find-charset feature-name) - ;; (cond - ;; ((and (= (charset-chars feature-name) 94) - ;; (= (charset-dimension feature-name) 2)) - ;; (www-format-value-as-CCS-94x94 value)) - ;; (t - ;; (www-format-value-as-CCS-default value))) - ;; ) - ;; (t - ;; (www-format-value-as-S-exp value))) - (www-format-apply-value format nil value nil nil without-tags) +(defun www-format-value (object feature-name + &optional value format without-tags) + (unless value + (setq value (www-char-feature object feature-name))) + (www-format-apply-value object feature-name + format nil value nil nil without-tags) ) @@ -352,7 +403,7 @@ (defun www-format-encode-string (string &optional without-tags) (with-temp-buffer (insert string) - (let (plane code) + (let (plane code start end char variants ret) (goto-char (point-min)) (while (search-forward "<" nil t) (replace-match "<" nil t)) @@ -375,11 +426,12 @@ '(=jis-x0208@1990 "J90-" 4 X) '(=jis-x0212 "JSP-" 4 X) '(=cbeta "CB" 5 d) - '(=jef-china3 "JC3-" 4 X) '(=jis-x0208@1997 "J97-" 4 X) '(=jis-x0208@1978 "J78-" 4 X) '(=jis-x0208@1983 "J83-" 4 X) + '(=gt "GT-" 5 d) '(=zinbun-oracle "ZOB-" 4 d) + '(=jef-china3 "JC3-" 4 X) '(=daikanwa "M-" 5 d) coded-charset-entity-reference-alist))) (encode-coding-region (point-min)(point-max) 'utf-8-mcs-er) @@ -390,7 +442,7 @@ (replace-match (format "\"CB%05d\"" code - chise-wiki-glyphs-url + chise-wiki-bitmap-glyphs-url (/ code 1000) code) t 'literal)) @@ -401,7 +453,7 @@ (replace-match (format "\"J%s-%04X\"" plane code - chise-wiki-glyphs-url + chise-wiki-bitmap-glyphs-url plane (- (lsh code -8) 32) (- (logand code 255) 32)) @@ -414,7 +466,7 @@ (replace-match (format "\"GB%d-%04X\"" plane code - chise-wiki-glyphs-url + chise-wiki-bitmap-glyphs-url plane (- (lsh code -8) 32) (- (logand code 255) 32)) @@ -427,14 +479,88 @@ (replace-match (format "\"CNS%d-%04X\"" plane code - chise-wiki-glyphs-url + chise-wiki-bitmap-glyphs-url plane code) t 'literal)) - )) - (goto-char (point-min)) - (while (search-forward ">-" nil t) - (replace-match "&GT-" t 'literal)) + (goto-char (point-min)) + (while (re-search-forward "&JC3-\\([0-9A-F][0-9A-F][0-9A-F][0-9A-F]\\);" nil t) + (setq code (string-to-int (match-string 1) 16)) + (replace-match + (format "\"JC3-%04X\"" + code code) + t 'literal)) + + (goto-char (point-min)) + (while (re-search-forward "&ZOB-\\([0-9]+\\);" nil t) + (setq code (string-to-int (match-string 1))) + (replace-match + (format "\"ZOB-%04d\"" + code + chise-wiki-bitmap-glyphs-url + code) + t 'literal)) + + (goto-char (point-min)) + (while (re-search-forward "&\\(G-\\)?GT-\\([0-9]+\\);" nil t) + (setq code (string-to-int (match-string 2))) + (replace-match + (format "\"GT-%05d\"" + code + chise-wiki-glyph-cgi-url + code) + t 'literal)) + + (goto-char (point-min)) + (while (re-search-forward "&B-\\([0-9A-F]+\\);" nil t) + (setq code (string-to-int (match-string 1) 16)) + (replace-match + (format "\"B-%04X\"" + code + chise-wiki-glyph-cgi-url + code) + t 'literal)) + + (goto-char (point-min)) + (while (re-search-forward "&CDP-\\([0-9A-F]+\\);" nil t) + (setq code (string-to-int (match-string 1) 16)) + (replace-match + (format "\"CDP-%04X\"" + code + chise-wiki-glyph-cgi-url + code) + t 'literal)) + + (goto-char (point-min)) + (while (re-search-forward "&\\(UU\\+\\|U-\\)\\([0-9A-F]+\\);" nil t) + (setq code (string-to-int (match-string 2) 16)) + (replace-match + (format "\"UU+%04X\"" + code + code) + t 'literal)) + + (goto-char (point-min)) + (while (re-search-forward "&MCS-\\([0-9A-F]+\\);" nil t) + (setq code (string-to-int (match-string 1) 16)) + (setq start (match-beginning 0) + end (match-end 0)) + (setq char (decode-char 'system-char-id code)) + (setq variants (or (www-char-feature char '->subsumptive) + (www-char-feature char '->denotational))) + (while (and variants + (setq ret (www-format-encode-string + (char-to-string (car variants)))) + (string-match "&MCS-\\([0-9A-F]+\\);" ret)) + (setq variants (cdr variants))) + (unless (string-match "&MCS-\\([0-9A-F]+\\);" ret) + (goto-char start) + (delete-region start end) + (insert ret))) + )) + ;; (goto-char (point-min)) + ;; (while (search-forward ">-" nil t) + ;; (replace-match "&GT-" t 'literal)) (buffer-string)))) (defun www-format-props-to-string (props &optional format) @@ -453,7 +579,8 @@ ((eq format 'S-exp) "S") (t "s")))) -(defun www-format-apply-value (format props value +(defun www-format-apply-value (object feature-name + format props value &optional uri-char uri-feature without-tags) (let (ret) @@ -467,6 +594,11 @@ (format "%s" value) without-tags)) ) + ((eq format 'wiki-text) + (if without-tags + (www-xml-format-list value) + (www-format-eval-list value object feature-name nil uri-char)) + ) ((eq format 'S-exp) (www-format-encode-string (format (www-format-props-to-string props format) @@ -479,7 +611,7 @@ ((eq format 'space-separated-ids) (www-format-value-as-ids value without-tags)) (t - (setq format 'default) + ;; (setq format 'default) (www-format-encode-string (format (www-format-props-to-string props 'default) value) @@ -496,12 +628,13 @@ feature-name &optional format lang uri-char value) (unless value - (setq value (char-feature char feature-name))) + (setq value (www-char-feature char feature-name))) (unless format (setq format (www-feature-value-format feature-name))) (cond ((symbolp format) (www-format-apply-value + char feature-name format nil value uri-char (www-uri-encode-feature-name feature-name)) ) @@ -509,6 +642,7 @@ (cond ((null (cdr format)) (setq format (car format)) (www-format-apply-value + char feature-name (car format) (nth 1 format) value uri-char (www-uri-encode-feature-name feature-name)) ) @@ -519,7 +653,7 @@ (defun www-format-eval-unit (exp char feature-name &optional lang uri-char value) (unless value - (setq value (char-feature char feature-name))) + (setq value (www-char-feature char feature-name))) (unless uri-char (setq uri-char (www-uri-encode-char char))) (cond @@ -533,6 +667,7 @@ (plist-get (nth 1 exp) :format) lang uri-char value) (www-format-apply-value + char feature-name (car exp) (nth 1 exp) value uri-char (www-uri-encode-feature-name feature-name))) ) @@ -571,6 +706,72 @@ (www-format-eval-unit format-list char feature-name lang uri-char))) +;;; @ XML generator +;;; + +(defun www-xml-format-props (props) + (let ((dest "") + key val) + (while props + (setq key (pop props) + val (pop props)) + (if (symbolp key) + (setq key (symbol-name key))) + (if (eq (aref key 0) ?:) + (setq key (substring key 1))) + (setq dest + (format "%s %s=\"%s\"" + dest key + (www-format-encode-string + (format "%s" val) 'without-tags)))) + dest)) + +(defun www-xml-format-unit (format-unit) + (let (name props children ret) + (cond + ((stringp format-unit) + (mapconcat (lambda (c) + (cond + ((eq c ?&) "&") + ;; ((eq c ?<) "&lt;") + ;; ((eq c ?>) "&gt;") + (t + (char-to-string c)))) + (www-format-encode-string format-unit 'without-tags) + "") + ) + ((consp format-unit) + (setq name (car format-unit) + props (nth 1 format-unit) + children (nthcdr 2 format-unit)) + (when (eq name 'link) + (setq ret (plist-get props :ref)) + (unless (stringp ret) + (setq props (plist-remprop (copy-list props) :ref)) + (setq children + (cons (list* 'ref nil ret) + children)))) + (if children + (format "<%s%s>%s" + name + (if props + (www-xml-format-props props) + "") + (www-xml-format-list children) + name) + (format "<%s%s/>" + name (www-xml-format-props props))) + ) + (t + (format "%s" format-unit))))) + +(defun www-xml-format-list (format-list) + (if (atom format-list) + (www-xml-format-unit format-list) + (mapconcat #'www-xml-format-unit + format-list ""))) + + ;;; @ HTML generator ;;;