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-char-desc (uri-char feature value format &optional lang)
 189   (when (stringp feature)
 190     (setq feature (intern feature)))
 191   (when (stringp format)
 192     (setq format (intern format)))
 193   (let ((char (www-uri-decode-object 'character uri-char))
 194         latest-feature
 195         logical-feature displayed-features
 196         ret)
 197     (when (characterp char)
 198       (princ
 199        (encode-coding-string
 200         (format "<head>
 201 <title>CHISE-wiki character: %s</title>
 202 </head>\n"
 203                 (decode-uri-string uri-char 'utf-8-mcs-er))
 204         'utf-8-mcs-er))
 205       (princ "<body>\n")
 206       (www-html-display-paragraph
 207        (format "char: %S %S %S %S\n"
 208                uri-char feature value lang))
 209       (setq value (www-feature-parse-string feature value format))
 210       (www-html-display-paragraph
 211        (format "char = %c : %S \u2190 %S"
 212                char feature value))
 213       (setq latest-feature
 214             (char-feature-name-at-domain feature '$rev=latest))
 215       (if value
 216           (if (equal (www-get-feature-value char feature) value)
 217               (www-html-display-paragraph
 218                "Feature-value is not changed.")
 219             ;; (www-html-display-paragraph
 220             ;;  (format "New feature-value = %S is different from old value %S"
 221             ;;          value
 222             ;;          (www-get-feature-value char feature)))
 223             (put-char-attribute char latest-feature value)
 224             (save-char-attribute-table latest-feature)
 225             (setq ret (char-feature-property '$object 'additional-features))
 226             (unless (memq feature ret)
 227               (put-char-feature-property
 228                '$object 'additional-features (cons feature ret)))
 229             )
 230         (www-html-display-paragraph
 231          "New feature-value is nil, so it is ignored (may be syntax error).")
 232         )
 233       (princ (format "<h1>%s</h1>\n"
 234                      (www-format-encode-string (char-to-string char))))
 235       (dolist (feature (char-feature-property '$object 'additional-features))
 236         (mount-char-attribute-table
 237          (char-feature-name-at-domain feature '$rev=latest)))
 238       (dolist (cell (sort (char-attribute-alist char)
 239                           (lambda (a b)
 240                             (char-attribute-name< (car a)(car b)))))
 241         (setq logical-feature
 242               (char-feature-name-sans-versions (car cell)))
 243         (unless (memq logical-feature displayed-features)
 244           (push logical-feature displayed-features)
 245           (princ "<p>")
 246           (princ
 247            (www-format-eval-list
 248             (or (char-feature-property logical-feature 'format)
 249                 '((name) " : " (value)))
 250             char logical-feature lang uri-char))
 251           (princ
 252            (format " <a href=\"%s?char=%s&feature=%s&format=wiki-text\"
 253 ><input type=\"submit\" value=\"note\" /></a>"
 254                    chise-wiki-edit-url
 255                    (www-format-encode-string uri-char)
 256                    (www-format-encode-string
 257                     (www-uri-encode-feature-name
 258                      (intern (format "%s*note" logical-feature))))))
 259           (princ "</p>\n")
 260           ))
 261       (princ
 262        (format "<p><a href=\"%s?char=%s\"
 263 ><input type=\"submit\" value=\"add feature\" /></a></p>"
 264                chise-wiki-add-url
 265                (www-format-encode-string uri-char)))
 266       )))
 267
 268 (defun www-set-display-feature-desc (feature-name property-name value format
 269                                                   &optional lang uri-char)
 270   (www-html-display-paragraph
 271    (format
 272     "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, char: %S\n"
 273     feature-name property-name format value lang uri-char))
 274   (setq value (www-feature-parse-string property-name value format))
 275   (www-html-display-paragraph
 276    (format
 277     "set: feature: %S, property-name: %S, format: %S, value: %S, lang: %S, char: %S\n"
 278     feature-name property-name format value lang uri-char))
 279   (put-char-feature-property feature-name property-name value)
 280   (let ((name@lang (intern (format "name@%s" lang)))
 281         (uri-feature-name (www-uri-encode-feature-name feature-name)))
 282     (princ
 283      (encode-coding-string
 284       (format "<head>
 285 <title>CHISE-wiki feature: %s</title>
 286 </head>\n"
 287               feature-name)
 288       'utf-8-mcs-er))
 289     (princ "<body>\n")
 290     (princ
 291      (encode-coding-string
 292       (format "<h1>%s</h1>\n"
 293               feature-name)
 294       'utf-8-mcs-er))
 295     (princ
 296      (format "<p>name : %s <a href=\"%s?feature=%s&property=name\"
 297 ><input type=\"submit\" value=\"edit\" /></a></p>
 298 "
 299              (or (www-format-feature-name feature-name) "")
 300              chise-wiki-edit-url
 301              ;; (char-feature-property feature-name 'name)
 302              uri-feature-name ; (www-uri-encode-feature-name feature-name)
 303              ))
 304     (when lang
 305       (princ
 306        (format "<p>%s : %s <a href=\"%s?feature=%s&property=%s\"
 307 ><input type=\"submit\" value=\"edit\" /></a></p>
 308 "
 309                name@lang
 310                (www-format-encode-string
 311                 (or (char-feature-property feature-name name@lang) ""))
 312                chise-wiki-edit-url
 313                uri-feature-name
 314                name@lang)))
 315     (www-html-display-paragraph
 316      (format "type : %s"
 317              (or (www-feature-type feature-name)
 318                  ;; (char-feature-property feature-name 'type)
 319                  'generic)))
 320     (princ (format "<p>value-format : %s "
 321                    (www-format-value
 322                     nil 'value-format
 323                     (or (www-feature-value-format feature-name)
 324                         'default)
 325                     'default
 326                     'without-tags)))
 327     (princ
 328      (format
 329       " <a href=\"%s?feature=%s&property=value-format&format=wiki-text&char=%s\"
 330 ><input type=\"submit\" value=\"edit\" /></a></p>"
 331       chise-wiki-edit-url
 332       uri-feature-name
 333       uri-char))
 334     (www-html-display-paragraph
 335      (format "description : %s"
 336              (or (char-feature-property feature-name 'description)
 337                  "")))
 338     (when lang
 339       (www-html-display-paragraph
 340        (format "description@%s : %s"
 341                lang
 342                (or (char-feature-property
 343                     feature-name
 344                     (intern (format "description@%s" lang)))
 345                    ""))))
 346     (princ "<hr />")
 347     (www-html-display-paragraph
 348      (format "「[[%c|%s?char=%s]]」に\u623Bる"
 349              (www-uri-decode-object 'character uri-char)
 350              chise-wiki-view-url
 351              uri-char))
 352     ))
 353
 354 (defun www-batch-set ()
 355   (setq terminal-coding-system 'binary)
 356   (condition-case err
 357       (let* ((target (pop command-line-args-left))
 358              (user (pop command-line-args-left))
 359              (accept-language (pop command-line-args-left))
 360              (lang
 361               (intern (car (split-string
 362                             (car (split-string
 363                                   (car (split-string accept-language ","))
 364                                   ";"))
 365                             "-"))))
 366              ret name val prop)
 367         (princ "Content-Type: text/html; charset=UTF-8
 368
 369 <!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\"
 370             \"http://www.w3.org/TR/html4/loose.dtd\">
 371 <html lang=\"ja\">
 372 ")
 373         (setq target
 374               (mapcar (lambda (cell)
 375                         (if (string-match "=" cell)
 376                             (progn
 377                               (setq name (substring
 378                                           cell 0 (match-beginning 0))
 379                                     val (substring cell (match-end 0)))
 380                               (cons
 381                                (intern
 382                                 (decode-uri-string name 'utf-8-mcs-er))
 383                                val))
 384                           (list (decode-uri-string cell 'utf-8-mcs-er))))
 385                       (split-string target "&")))
 386         (setq ret (car target))
 387         (cond ((eq (car ret) 'char)
 388                (setq prop (nth 2 target))
 389                (www-set-display-char-desc
 390                 (cdr ret) ; (decode-uri-string (cdr ret) 'utf-8-mcs-er)
 391                 (intern (decode-uri-string
 392                          (cdr (assq 'feature-name target))
 393                          'utf-8-mcs-er))
 394                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
 395                 (car prop)
 396                 lang)
 397                )
 398               ((eq (car ret) 'feature)
 399                (setq prop (nth 3 target))
 400                (www-set-display-feature-desc
 401                 (intern (decode-uri-string (cdr ret) 'utf-8-mcs-er))
 402                 (intern (decode-uri-string
 403                          (cdr (assq 'feature-name (cdr target)))
 404                          'utf-8-mcs-er))
 405                 (cdr prop) ; (decode-uri-string (cdr prop) 'utf-8-mcs-er)
 406                 (car prop)
 407                 lang
 408                 (cdr (assq 'char target))
 409                 )
 410                ))
 411         (www-html-display-paragraph
 412          (format "%S" target))
 413         (princ "\n<hr>\n")
 414         (princ (format "user=%s\n" user))
 415         (princ (format "local user=%s\n" (user-login-name)))
 416         (princ (format "lang=%S\n" lang))
 417         (princ emacs-version)
 418         (princ " CHISE ")
 419         (princ (encode-coding-string xemacs-chise-version 'utf-8-jp-er))
 420         (princ "
 421 </body>
 422 </html>")
 423         )
 424     (error nil
 425            (princ (format "%S" err)))
 426     ))