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