(est-coded-charset-entity-reference-alist): New variable.
[chise/est.git] / cwiki-set.el
1 ;; -*- coding: utf-8-mcs-er -*-
2 (defvar chise-wiki-view-url "view.cgi")
3 (defvar chise-wiki-edit-url "edit.cgi")
4
5 (require 'cwiki-view)
6
7
8 ;;; @ stext parser
9 ;;;
10
11 (defun www-xml-parse-string (string)
12   (require 'xml)
13   (nthcdr
14    2
15    (car
16     (with-temp-buffer
17       (insert "<top>")
18       (insert string)
19       (insert "</top>")
20       (xml-parse-region (point-min)(point-max))))))
21
22 (defun www-xml-to-stext-props (props)
23   (let (dest)
24     (dolist (cell props)
25       (setq dest (cons (cdr cell)
26                        (cons (intern (format ":%s" (car cell)))
27                              dest))))
28     (nreverse dest)))
29
30 (defun www-xml-to-stext-unit (unit)
31   (let (name props children)
32     (cond
33      ((stringp unit)
34       unit)
35      ((consp unit)
36       (setq name (car unit))
37       (if (stringp name)
38           nil
39         (setq props (www-xml-to-stext-props (nth 1 unit))
40               children (nthcdr 2 unit))
41         (if children
42             (setq children (www-xml-to-stext-list children)))
43         (when (and (eq name 'link)
44                    (consp (car children))
45                    (eq (caar children) 'ref))
46           (setq props (list* :ref (nthcdr 2 (car children))
47                              props)
48                 children (cdr children)))
49         (if children
50             (list* name props children)
51           (if props
52               (list name props)
53             (list name))))
54       )
55      (t
56       (format "%S" unit)))))
57
58 (defun www-xml-to-stext-list (trees)
59   (cond
60    ((atom trees)
61     (www-xml-to-stext-unit trees)
62     )
63    ((equal trees '(("")))
64     nil)
65    (t
66     (mapcar #'www-xml-to-stext-unit
67             trees))))
68
69 (defun www-stext-parse-xml-string (string)
70   (www-xml-to-stext-list
71    (www-xml-parse-string string)))
72
73
74 ;;; @ parser
75 ;;;
76
77 (defun www-parse-string-default (string)
78   (setq string (decode-uri-string string 'utf-8-mcs-er))
79   (condition-case nil
80       ;; (let ((ret
81       ;;        (mapcar #'read (split-string string " "))))
82       ;;   (if (cdr ret)
83       ;;       ret
84       ;;     (car ret)))
85       (let ((i 0)
86             (len (length string))
87             dest ret)
88         (while (< i len)
89           (setq ret (read-from-string string i))
90           (setq dest (cons (car ret) dest)
91                 i (cdr ret)))
92         (if (cdr dest)
93             (nreverse dest)
94           (if (atom (car dest))
95               (car dest)
96             (nreverse dest))))
97     (error nil)))
98
99 (defun www-parse-string-as-space-separated-char-list (string genre)
100   (let (dest char)
101     (dolist (unit (split-string string "\\+"))
102       (if (setq char (www-uri-decode-object genre unit))
103           (setq dest (cons char dest))))
104     (nreverse dest)))
105
106 (defun www-parse-string-as-space-separated-ids (string)
107   (cdar
108    (ids-parse-string
109     (let (char)
110       (mapconcat
111        (lambda (unit)
112          (if (setq char (www-uri-decode-object 'character unit))
113              (char-to-string char)
114            unit))
115        (split-string string "\\+")
116        "")))))
117
118 (defun www-parse-string-as-ku-ten (string)
119   (if (string-match "^\\([0-9][0-9]?\\)-\\([0-9][0-9]?\\)" string)
120       (let ((ku (string-to-int (match-string 1 string)))
121             (ten (string-to-int (match-string 2 string))))
122         (if (and (<= 1 ku)(<= ku 94)
123                  (<= 1 ten)(<= ten 94))
124             (+ (lsh (+ ku 32) 8)
125                ten 32)))))
126
127 (defun www-parse-string-as-kangxi-radical (string)
128   (setq string (decode-uri-string string 'utf-8-mcs-er))
129   (let ((i 0)
130         (len (length string))
131         char ret)
132     (while (and (< i len)
133                 (setq char (aref string i))
134                 (not
135                  (and (setq ret (char-ucs char))
136                       (<= #x2F00 ret)
137                       (<= ret #x2FD5)))
138                 (not (setq ret (char-feature char '->radical))))
139       (setq i (1+ i)))
140     (if (integerp ret)
141         (- ret #x2EFF)
142       (and (setq ret (car ret))
143            (setq ret (char-ucs ret))
144            (<= #x2F00 ret)
145            (<= ret #x2FD5)
146            (- ret #x2EFF)))))
147
148 (defun www-parse-string-as-wiki-text (string)
149   (www-stext-parse-xml-string
150    (decode-uri-string string 'utf-8-mcs-er))
151   ;; (list (decode-uri-string string 'utf-8-mcs-er))
152   )
153
154 (defun www-feature-parse-string (genre feature-name string &optional format)
155   (unless format
156     (setq format (www-feature-value-format feature-name)))
157   (cond ((eq format 'space-separated-char-list)
158          (www-parse-string-as-space-separated-char-list string genre))
159         ((eq format 'space-separated-ids)
160          (www-parse-string-as-space-separated-ids string))
161         ((eq format 'ku-ten)
162          (www-parse-string-as-ku-ten string))
163         ((eq format 'decimal)
164          (string-to-number string))
165         ((or (eq format 'HEX)(eq format 'hex))
166          (string-to-number string 16))
167         ((eq format 'string)
168          (decode-uri-string string 'utf-8-mcs-er)
169          )
170         ((eq format 'kangxi-radical)
171          (www-parse-string-as-kangxi-radical string))
172         ((eq format 'wiki-text)
173          (www-parse-string-as-wiki-text string)
174          )
175         ((eq format 'S-exp)
176          (if (= (length string) 0)
177              nil
178            (read (decode-uri-string string 'utf-8-mcs-er)))
179          )
180         (t 
181          (www-parse-string-default string)
182          )))
183
184
185 ;;; @ display
186 ;;;
187
188 (defun www-set-display-object-desc (genre uri-object feature value format
189                                           &optional lang)
190   (when (stringp feature)
191     (setq feature (intern feature)))
192   (when (stringp format)
193     (setq format (intern format)))
194   (let ((object (www-uri-decode-object genre uri-object))
195         latest-feature
196         logical-feature displayed-features
197         ret)
198     (when object
199       (princ
200        (encode-coding-string
201         (format "<head>
202 <title>EsT %s = %s</title>
203 </head>\n"
204                 genre
205                 (decode-uri-string uri-object 'utf-8-mcs-er))
206         'utf-8-mcs-er))
207       (princ "<body>\n")
208       (www-html-display-paragraph
209        (format "object: %S (%S) %S %S %S\n"
210                uri-object genre feature value lang))
211       (setq value (www-feature-parse-string genre feature value format))
212       (www-html-display-paragraph
213        (format "object = %s (%s) : %S \u2190 %S"
214                (est-format-object object) genre feature value))
215       (setq latest-feature
216             (char-feature-name-at-domain feature '$rev=latest))
217       (if value
218           (if (equal (www-get-feature-value object feature) value)
219               (www-html-display-paragraph
220                "Feature-value is not changed.")
221             ;; (www-html-display-paragraph
222             ;;  (format "New feature-value = %S is different from old value %S"
223             ;;          value
224             ;;          (www-get-feature-value object feature)))
225             (cond
226              ((characterp object)
227               (put-char-attribute object latest-feature value)
228               (save-char-attribute-table latest-feature)
229               (setq ret (char-feature-property '$object 'additional-features))
230               (unless (memq feature ret)
231                 (put-char-feature-property
232                  '$object 'additional-features (cons feature ret)))
233               )
234              (t
235               (concord-object-put object latest-feature value)
236               ))
237             )
238         (www-html-display-paragraph
239          "New feature-value is nil, so it is ignored (may be syntax error).")
240         )
241       (www-display-object-desc genre uri-object nil lang 1)
242       ;; (princ (format "<h1>%s</h1>\n"
243       ;;                (www-format-encode-string (char-to-string object))))
244       ;; (dolist (feature (char-feature-property '$object 'additional-features))
245       ;;   (mount-char-attribute-table
246       ;;    (char-feature-name-at-domain feature '$rev=latest)))
247       ;; (dolist (cell (sort (char-attribute-alist object)
248       ;;                     (lambda (a b)
249       ;;                       (char-attribute-name< (car a)(car b)))))
250       ;;   (setq logical-feature
251       ;;         (char-feature-name-sans-versions (car cell)))
252       ;;   (unless (memq logical-feature displayed-features)
253       ;;     (push logical-feature displayed-features)
254       ;;     (princ "<p>")
255       ;;     (princ
256       ;;      (www-format-eval-list
257       ;;       (or (char-feature-property logical-feature 'format)
258       ;;           '((name) " : " (value)))
259       ;;       object logical-feature lang uri-object))
260       ;;     (princ
261       ;;      (format " <a href=\"%s?char=%s&feature=%s&format=wiki-text\"
262 ;;><inpu;; t type=\"submit\" value=\"note\" /></a>"
263       ;;              chise-wiki-edit-url
264       ;;              (www-format-encode-string uri-object)
265       ;;              (www-format-encode-string
266       ;;               (www-uri-encode-feature-name
267       ;;                (intern (format "%s*note" logical-feature))))))
268       ;;     (princ "</p>\n")
269       ;;     ))
270       ;; (princ
271       ;;  (format "<p><a href=\"%s?char=%s\"
272 ;;><inpu;; t type=\"submit\" value=\"add feature\" /></a></p>"
273       ;;          chise-wiki-add-url
274       ;;          (www-format-encode-string uri-object)))
275       )))
276
277 (defun www-set-display-feature-desc (feature-name property-name value format
278                                                   &optional lang uri-object)
279   (www-html-display-paragraph
280    (format
281     "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, object: %S\n"
282     feature-name property-name format value lang uri-object))
283   (setq value (www-feature-parse-string 'feature property-name value format))
284   (www-html-display-paragraph
285    (format
286     "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, object: %S\n"
287     feature-name property-name format value lang uri-object))
288   (put-char-feature-property feature-name property-name value)
289   (let ((name@lang (intern (format "name@%s" lang)))
290         (uri-feature-name (www-uri-encode-feature-name feature-name)))
291     (princ
292      (encode-coding-string
293       (format "<head>
294 <title>CHISE-wiki feature: %s</title>
295 </head>\n"
296               feature-name)
297       'utf-8-mcs-er))
298     (princ "<body>\n")
299     (princ
300      (encode-coding-string
301       (format "<h1>%s</h1>\n"
302               feature-name)
303       'utf-8-mcs-er))
304     (princ
305      (format "<p>name : %s <a href=\"%s?feature=%s&property=name\"
306 ><input type=\"submit\" value=\"edit\" /></a></p>
307 "
308              (or (www-format-feature-name feature-name) "")
309              chise-wiki-edit-url
310              ;; (char-feature-property feature-name 'name)
311              uri-feature-name ; (www-uri-encode-feature-name feature-name)
312              ))
313     (when lang
314       (princ
315        (format "<p>%s : %s <a href=\"%s?feature=%s&property=%s\"
316 ><input type=\"submit\" value=\"edit\" /></a></p>
317 "
318                name@lang
319                (www-format-encode-string
320                 (or (char-feature-property feature-name name@lang) ""))
321                chise-wiki-edit-url
322                uri-feature-name
323                name@lang)))
324     (www-html-display-paragraph
325      (format "type : %s"
326              (or (www-feature-type feature-name)
327                  ;; (char-feature-property feature-name 'type)
328                  'generic)))
329     (princ (format "<p>value-format : %s "
330                    (www-format-value
331                     nil 'value-format 
332                     (or (www-feature-value-format feature-name)
333                         'default)
334                     'default
335                     'without-tags)))
336     (princ
337      (format
338       " <a href=\"%s?feature=%s&property=value-format&format=wiki-text&char=%s\"
339 ><input type=\"submit\" value=\"edit\" /></a></p>"
340       chise-wiki-edit-url
341       uri-feature-name
342       uri-object))
343     (www-html-display-paragraph
344      (format "description : %s"
345              (or (char-feature-property feature-name 'description)
346                  "")))
347     (when lang
348       (www-html-display-paragraph
349        (format "description@%s : %s"
350                lang
351                (or (char-feature-property
352                     feature-name
353                     (intern (format "description@%s" lang)))
354                    ""))))
355     (princ "<hr />")
356     (www-html-display-paragraph
357      (format "「[[%c|%s?char=%s]]」に\u623Bる"
358              (www-uri-decode-object 'character uri-object)
359              chise-wiki-view-url
360              uri-object))
361     ))
362
363 (defun www-batch-set ()
364   (setq terminal-coding-system 'binary)
365   (condition-case err
366       (let* ((target (pop command-line-args-left))
367              (user (pop command-line-args-left))
368              (accept-language (pop command-line-args-left))
369              (lang
370               (intern (car (split-string
371                             (car (split-string
372                                   (car (split-string accept-language ","))
373                                   ";"))
374                             "-"))))
375              ret name val prop)
376         (princ "Content-Type: text/html; charset=UTF-8
377
378 <!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
379             \"http://www.w3.org/TR/html4/loose.dtd\">
380 <html lang=\"ja\">
381 ")
382         (setq target
383               (mapcar (lambda (cell)
384                         (if (string-match "=" cell)
385                             (progn
386                               (setq name (substring
387                                           cell 0 (match-beginning 0))
388                                     val (substring cell (match-end 0)))
389                               (cons
390                                (intern
391                                 (decode-uri-string name 'utf-8-mcs-er))
392                                val))
393                           (list (decode-uri-string cell 'utf-8-mcs-er))))
394                       (split-string target "&")))
395         (setq ret (car target))
396         (cond ((eq (car ret) 'char)
397                (setq prop (nth 2 target))
398                (www-set-display-object-desc
399                 'character
400                 (cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
401                 (intern (decode-uri-string
402                          (cdr (assq 'feature-name target))
403                          'utf-8-mcs-er))
404                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
405                 (car prop)
406                 lang)
407                )
408               ((eq (car ret) 'feature)
409                (setq prop (nth 3 target))
410                (www-set-display-feature-desc
411                 (intern (decode-uri-string (cdr ret) 'utf-8-mcs-er))
412                 (intern (decode-uri-string
413                          (cdr (assq 'feature-name (cdr target)))
414                          'utf-8-mcs-er))
415                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
416                 (car prop)
417                 lang
418                 (cdr (assq 'char target))
419                 )
420                )
421               (t
422                (setq prop (nth 2 target))
423                (www-set-display-object-desc
424                 (car ret)
425                 (cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
426                 (intern (decode-uri-string
427                          (cdr (assq 'feature-name target))
428                          'utf-8-mcs-er))
429                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
430                 (car prop)
431                 lang)
432                ))
433         (www-html-display-paragraph
434          (format "%S" target))
435         (princ "\n<hr>\n")
436         (princ (format "user=%s\n" user))
437         (princ (format "local user=%s\n" (user-login-name)))
438         (princ (format "lang=%S\n" lang))
439         (princ emacs-version)
440         (princ " CHISE ")
441         (princ (encode-coding-string xemacs-chise-version 'utf-8-jp-er))
442         (princ "
443 </body>
444 </html>")
445         )
446     (error nil
447            (princ (format "%S" err)))
448     ))