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