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