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