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