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)
 100   (let (dest char)
 101     (dolist (unit (split-string string "\\+"))
 102       (if (setq char (www-uri-decode-object 'character 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 (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))
 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 'character uri-object))
 195         latest-feature
 196         logical-feature displayed-features
 197         ret)
 198     (when (characterp object)
 199       (princ
 200        (encode-coding-string
 201         (format "<head>
 202 <title>CHISE-wiki character: %s</title>
 203 </head>\n"
 204                 (decode-uri-string uri-object '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-object 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                object feature value))
 214       (setq latest-feature
 215             (char-feature-name-at-domain feature '$rev=latest))
 216       (if value
 217           (if (equal (www-get-feature-value object 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-get-feature-value object feature)))
 224             (put-char-attribute object 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 object))))
 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 object)
 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             object logical-feature lang uri-object))
 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-object)
 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-object)))
 267       )))
 268
 269 (defun www-set-display-feature-desc (feature-name property-name value format
 270                                                   &optional lang uri-object)
 271   (www-html-display-paragraph
 272    (format
 273     "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, object: %S\n"
 274     feature-name property-name format value lang uri-object))
 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, object: %S\n"
 279     feature-name property-name format value lang uri-object))
 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-object))
 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|%s?char=%s]]」に\u623Bる"
 350              (www-uri-decode-object 'character uri-object)
 351              chise-wiki-view-url
 352              uri-object))
 353     ))
 354
 355 (defun www-batch-set ()
 356   (setq terminal-coding-system 'binary)
 357   (condition-case err
 358       (let* ((target (pop command-line-args-left))
 359              (user (pop command-line-args-left))
 360              (accept-language (pop command-line-args-left))
 361              (lang
 362               (intern (car (split-string
 363                             (car (split-string
 364                                   (car (split-string accept-language ","))
 365                                   ";"))
 366                             "-"))))
 367              ret name val prop)
 368         (princ "Content-Type: text/html; charset=UTF-8
 369
 370 <!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 371             \"http://www.w3.org/TR/html4/loose.dtd\">
 372 <html lang=\"ja\">
 373 ")
 374         (setq target
 375               (mapcar (lambda (cell)
 376                         (if (string-match "=" cell)
 377                             (progn
 378                               (setq name (substring
 379                                           cell 0 (match-beginning 0))
 380                                     val (substring cell (match-end 0)))
 381                               (cons
 382                                (intern
 383                                 (decode-uri-string name 'utf-8-mcs-er))
 384                                val))
 385                           (list (decode-uri-string cell 'utf-8-mcs-er))))
 386                       (split-string target "&")))
 387         (setq ret (car target))
 388         (cond ((eq (car ret) 'char)
 389                (setq prop (nth 2 target))
 390                (www-set-display-object-desc
 391                 'character
 392                 (cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
 393                 (intern (decode-uri-string
 394                          (cdr (assq 'feature-name target))
 395                          'utf-8-mcs-er))
 396                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
 397                 (car prop)
 398                 lang)
 399                )
 400               ((eq (car ret) 'feature)
 401                (setq prop (nth 3 target))
 402                (www-set-display-feature-desc
 403                 (intern (decode-uri-string (cdr ret) 'utf-8-mcs-er))
 404                 (intern (decode-uri-string
 405                          (cdr (assq 'feature-name (cdr target)))
 406                          'utf-8-mcs-er))
 407                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
 408                 (car prop)
 409                 lang
 410                 (cdr (assq 'char target))
 411                 )
 412                )
 413               (t
 414                (setq prop (nth 3 target))
 415                (www-set-display-object-desc
 416                 (car ret)
 417                 (cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
 418                 (intern (decode-uri-string
 419                          (cdr (assq 'feature-name target))
 420                          'utf-8-mcs-er))
 421                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
 422                 (car prop)
 423                 lang)
 424                ))
 425         (www-html-display-paragraph
 426          (format "%S" target))
 427         (princ "\n<hr>\n")
 428         (princ (format "user=%s\n" user))
 429         (princ (format "local user=%s\n" (user-login-name)))
 430         (princ (format "lang=%S\n" lang))
 431         (princ emacs-version)
 432         (princ " CHISE ")
 433         (princ (encode-coding-string xemacs-chise-version 'utf-8-jp-er))
 434         (princ "
 435 </body>
 436 </html>")
 437         )
 438     (error nil
 439            (princ (format "%S" err)))
 440     ))