est-rdf-view.el

   1 ;; -*- coding: utf-8-mcs-er -*-
   2 (require 'cwiki-format)
   3
   4 (defvar chise-wiki-view-url "view.cgi")
   5 (defvar chise-wiki-edit-url "edit.cgi")
   6 (defvar chise-wiki-add-url "add.cgi")
   7
   8 (defun est-rdf-encode-feature-name (feature-name)
   9   (let ((str (symbol-name feature-name))
  10         base domain
  11         ret is-not-top
  12         xmlns-prefix xmlns-uri)
  13     (if (string-match "@" str)
  14         (setq base (substring str 0 (match-beginning 0))
  15               domain (substring str (match-end 0)))
  16       (setq base str))
  17     (setq ret (mapconcat (lambda (c)
  18                            (prog1
  19                                (cond ((eq c ?*)
  20                                       (if is-not-top
  21                                           ".-."
  22                                         "meta."))
  23                                      ((eq c ?/)
  24                                       "...")
  25                                      (t (char-to-string c)))
  26                              (setq is-not-top t)))
  27                          base ""))
  28     (if domain
  29         (setq xmlns-prefix
  30               (or xmlns-prefix
  31                   (concat "est."
  32                           (mapconcat #'identity
  33                                      (split-string domain "/")
  34                                      "."))))
  35       (setq xmlns-prefix (or (char-feature-property
  36                               feature-name 'rdf-namespace-prefix)
  37                              'est)
  38             xmlns-uri (char-feature-property
  39                        feature-name 'rdf-namespace-uri)))
  40     (list xmlns-prefix
  41           (or xmlns-uri
  42               (format "http://www.chise.org/est/rdf.cgi?domain=%s/"
  43                       xmlns-prefix))
  44           (www-uri-encode-feature-name (intern ret)))))
  45
  46 (defun est-rdf-format-object (obj)
  47   (if (or (characterp obj)
  48           (concord-object-p obj))
  49       (let ((genre (est-object-genre obj))
  50             (url-object (www-uri-encode-object obj)))
  51         (format "
  52     <rdf:Description
  53      rdf:about=\"http://www.chise.org/est/rdf.cgi?%s=%s\">
  54     </rdf:Description>"
  55                 genre url-object))
  56     (encode-coding-string (format "
  57     %s" obj)
  58                           'utf-8-mcs-er)))
  59
  60 (defun est-rdf-format-object-list (obj-list &optional with-li)
  61   ;; (concat (mapconcat #'est-rdf-format-object
  62   ;;                    obj-list
  63   ;;                    "")
  64   ;;         "\n")
  65   (let ((rest obj-list)
  66         dest obj)
  67     (while (consp rest)
  68       (setq obj (pop rest))
  69       (if with-li
  70           (setq dest (concat dest
  71                              "
  72     <rdf:li>"
  73                              (est-rdf-format-object obj)
  74                              "
  75     </rdf:li>"))
  76         (setq dest (concat dest (est-rdf-format-object obj)))))
  77     (if rest
  78         (setq dest (concat dest (est-rdf-format-object rest))))
  79     (concat dest "\n  ")))
  80
  81 (defun est-rdf-display-object-desc (genre uri-object &optional lang level)
  82   (unless level
  83     (setq level 0))
  84   (let ((object (www-uri-decode-object genre uri-object))
  85         logical-feature chise-wiki-displayed-features
  86         logical-feature-name
  87         object-spec logical-object-spec
  88         rdf-feature-name rdf-feature-name-space
  89         rdf-feature-name-base rdf-feature-name-domain rdf-feature-name-uri
  90         feature-type rdf-container
  91         value ret
  92         metadata-feature-target metadata-feature-type
  93         have-matedata)
  94     (if (eq level 0)
  95         (setq level 1))
  96     (when object
  97       (when (and (eq genre 'character)
  98                  (= (length uri-object) 1))
  99         (setq uri-object (www-uri-encode-object object)))
 100       (when (eq genre 'character)
 101         (dolist (feature (char-feature-property '$object 'additional-features))
 102           (mount-char-attribute-table
 103            (char-feature-name-at-domain feature '$rev=latest))))
 104       (setq object-spec
 105             (if (eq genre 'character)
 106                 (char-attribute-alist object)
 107               (concord-object-spec object)))
 108       (dolist (cell (sort object-spec
 109                           (lambda (a b)
 110                             (char-attribute-name<
 111                              (char-feature-name-sans-versions (car a))
 112                              (char-feature-name-sans-versions (car b))))))
 113         (setq logical-feature (char-feature-name-sans-versions (car cell)))
 114         (setq logical-feature-name (symbol-name logical-feature))
 115         (when (string-match "[^*]\\*[^*]+$" logical-feature-name)
 116           (setq metadata-feature-target
 117                 (intern (substring logical-feature-name
 118                                    0 (1+ (match-beginning 0)))))
 119           (push metadata-feature-target have-matedata))
 120         (push (cons logical-feature (cdr cell))
 121               logical-object-spec)
 122         )
 123       (dolist (cell (nreverse logical-object-spec))
 124         ;; (setq logical-feature (char-feature-name-sans-versions (car cell)))
 125         (setq logical-feature (car cell))
 126         (setq logical-feature-name (symbol-name logical-feature))
 127         (unless (memq logical-feature chise-wiki-displayed-features)
 128           (push logical-feature chise-wiki-displayed-features)
 129           (setq value (www-get-feature-value object logical-feature))
 130           (setq ret (est-rdf-encode-feature-name logical-feature))
 131           (setq rdf-feature-name-domain (car ret)
 132                 rdf-feature-name-uri (nth 1 ret)
 133                 rdf-feature-name-base (nth 2 ret))
 134           (setq rdf-feature-name (format "%s:%s"
 135                                          rdf-feature-name-domain
 136                                          rdf-feature-name-base))
 137           (setq rdf-feature-name-space
 138                 (format "xmlns:%s=\"%s\""
 139                         rdf-feature-name-domain
 140                         rdf-feature-name-uri))
 141           (setq feature-type (www-feature-type logical-feature))
 142           (if (and (consp value)
 143                    (cdr value))
 144               (cond
 145                ((eq feature-type 'structure)
 146                 (setq rdf-container "rdf:Seq")
 147                 )
 148                ;; ((eq feature-type 'relation)
 149                ;;  (setq rdf-container "rdf:Bag")
 150                ;;  )
 151                (t
 152                 (setq rdf-container "rdf:Bag")
 153                 ))
 154             (setq rdf-container nil))
 155           (cond
 156            ((string-match "[^*]\\*[^*]+$" logical-feature-name)
 157             (setq metadata-feature-target
 158                   (intern (substring logical-feature-name
 159                                      0 (1+ (match-beginning 0)))))
 160             ;; (setq metadata-feature-type
 161             ;;       (intern (substring logical-feature-name
 162             ;;                          (1+ (match-beginning 0)))))
 163             (setq metadata-feature-type
 164                   (intern (substring logical-feature-name
 165                                      (+ (match-beginning 0) 2))))
 166             (setq ret (est-rdf-encode-feature-name metadata-feature-target))
 167             (princ
 168              (format "<rdf:Description
 169  rdf:about=\"#%s...%s\">\n"
 170                      (car ret)(nth 2 ret)))
 171             (setq ret (est-rdf-encode-feature-name metadata-feature-type))
 172             (setq rdf-feature-name-domain (car ret)
 173                   rdf-feature-name-uri (nth 1 ret)
 174                   rdf-feature-name-base (nth 2 ret))
 175             (setq rdf-feature-name (format "%s:%s"
 176                                          rdf-feature-name-domain
 177                                          rdf-feature-name-base))
 178             (setq rdf-feature-name-space
 179                   (format "xmlns:%s=\"%s\""
 180                           rdf-feature-name-domain
 181                           rdf-feature-name-uri))
 182             )
 183            (t
 184             (setq metadata-feature-type nil)
 185             (princ
 186              (format "<rdf:Description
 187  rdf:about=\"http://www.chise.org/est/rdf.cgi?%s=%s\">\n"
 188                      genre uri-object
 189                      ))
 190             ))
 191           (princ
 192            (cond
 193             ((memq logical-feature have-matedata)
 194              ;; (setq ret (assq logical-feature feature-metadata-alist))
 195              (format "  <%s\n   %s\n   rdf:ID=\"%s...%s\">%s%s%s</%s>\n"
 196                      rdf-feature-name
 197                      rdf-feature-name-space
 198                      rdf-feature-name-domain rdf-feature-name-base
 199                      (if rdf-container
 200                          (format "\n  <%s>" rdf-container)
 201                        "")
 202                      (est-rdf-format-object-list value rdf-container)
 203                      (if rdf-container
 204                          (format "</%s>\n  " rdf-container)
 205                        "")
 206                      rdf-feature-name)
 207              )
 208             (t
 209              (format "  <%s\n   %s>%s%s%s</%s>\n"
 210                      rdf-feature-name
 211                      rdf-feature-name-space
 212                      (if rdf-container
 213                          (format "\n  <%s>" rdf-container)
 214                        "")
 215                      (est-rdf-format-object-list value rdf-container)
 216                      (if rdf-container
 217                          (format "</%s>\n  " rdf-container)
 218                        "")
 219                      rdf-feature-name)
 220              )))
 221           (princ "</rdf:Description>\n")
 222           ))
 223       )))
 224
 225 (defun est-rdf-display-feature-desc (uri-feature-name genre uri-object
 226                                                   &optional lang simple)
 227   (let ((feature-name (www-uri-decode-feature-name uri-feature-name))
 228         (name@lang (intern (format "name@%s" lang))))
 229     (princ
 230      (encode-coding-string
 231       (format "<head>
 232 <title>EsT feature: %s</title>
 233 </head>\n"
 234               feature-name)
 235       'utf-8-mcs-er))
 236     (princ "<body>\n")
 237     (princ
 238      (format
 239       (if simple
 240           "<div style=\"text-align:right;\">
 241 <a href=\"edit/view.cgi?feature=%s&%s=%s\">
 242 <input type=\"submit\" value=\"Edit\" />
 243 </a>
 244 <input type=\"submit\" value=\"New Account\" />
 245 </div>
 246 <hr />\n"
 247           "<div style=\"text-align:right;\">
 248 <a href=\"../view.cgi?feature=%s&%s=%s\">
 249 <input type=\"submit\" value=\"Simple\" />
 250 </a>
 251 </div>
 252 <hr />\n")
 253       uri-feature-name genre uri-object))
 254     (princ
 255      (format "<h1>%s</h1>\n"
 256              (www-format-encode-string
 257               (symbol-name feature-name))))
 258     (princ (format "<p>name : %s "
 259                    (or (www-format-feature-name feature-name) "")))
 260     (unless simple
 261       (princ
 262        (format
 263         " <a href=\"%s?feature=%s&property=name&format=string&%s=%s\">"
 264         chise-wiki-edit-url
 265         uri-feature-name
 266         genre
 267         uri-object))
 268       (princ "<input type=\"submit\" value=\"edit\" /></a>\n"))
 269     (princ "</p>\n")
 270     (when lang
 271       (princ "<p>")
 272       (princ
 273        (www-format-encode-string
 274         (format "%s : %s"
 275                 name@lang
 276                 (or (char-feature-property feature-name name@lang) ""))))
 277       (unless simple
 278         (princ
 279          (format
 280           " <a href=\"%s?feature=%s&property=%s&format=string&%s=%s\">"
 281           chise-wiki-edit-url
 282           uri-feature-name
 283           name@lang
 284           genre
 285           uri-object))
 286         (princ "<input type=\"submit\" value=\"edit\" /></a>\n"))
 287       (princ "</p>\n"))
 288     (www-html-display-paragraph
 289      (format "type : %s"
 290              (or (www-feature-type feature-name)
 291                  ;; (char-feature-property feature-name 'type)
 292                  'generic)))
 293     (princ (format "<p>value-format : %s "
 294                    (www-format-value
 295                     nil 'value-format
 296                     (or (www-feature-value-format feature-name)
 297                         'default)
 298                     'default
 299                     'without-tags)
 300                    ))
 301     (unless simple
 302       (princ
 303        (format
 304         " <a href=\"%s?feature=%s&property=value-format&format=wiki-text&%s=%s\"
 305 >"
 306         chise-wiki-edit-url
 307         uri-feature-name
 308         genre
 309         uri-object))
 310       (princ "<input type=\"submit\" value=\"edit\" /></a>\n"))
 311     (princ "</p>\n")
 312
 313     (princ "<p>format : ")
 314     (www-html-display-text
 315      (decode-coding-string
 316       (www-xml-format-list
 317        (www-feature-format feature-name))
 318       'utf-8-mcs-er))
 319     (unless simple
 320       (princ
 321        (format
 322         " <a href=\"%s?feature=%s&property=format&format=wiki-text&%s=%s\"
 323 >"
 324         chise-wiki-edit-url
 325         uri-feature-name
 326         genre
 327         uri-object))
 328       (princ "<input type=\"submit\" value=\"edit\" /></a>\n"))
 329     (princ "</p>\n")
 330
 331     (www-html-display-paragraph
 332      (format "description : %s"
 333              (or (char-feature-property feature-name 'description)
 334                  "")))
 335     (when lang
 336       (www-html-display-paragraph
 337        (format "description@%s : %s"
 338                lang
 339                (or (char-feature-property
 340                     feature-name
 341                     (intern (format "description@%s" lang)))
 342                    ""))))
 343     ))
 344
 345 (defun est-rdf-batch-view ()
 346   (setq terminal-coding-system 'binary)
 347   (condition-case err
 348       (let* ((target (pop command-line-args-left))
 349              (user (pop command-line-args-left))
 350              (accept-language (pop command-line-args-left))
 351              (mode (intern (pop command-line-args-left)))
 352              (lang
 353               (intern
 354                (car (split-string
 355                      (car (split-string
 356                            (car (split-string accept-language ","))
 357                            ";"))
 358                      "-"))))
 359              ret genre)
 360         (princ "Content-Type: application/xml
 361
 362 <?xml version=\"1.0\" encoding=\"UTF-8\" ?>
 363 <rdf:RDF
 364   xmlns:rdf=\"http://www.w3.org/1999/02/22-rdf-syntax-ns#\"
 365   xmlns:dc=\"http://purl.org/dc/elements/1.1/\">
 366 ")
 367         (cond
 368          ((stringp target)
 369           (when (string-match "^char=\\(&[^&;]+;\\)" target)
 370             (setq ret (match-end 0))
 371             (setq target
 372                   (concat "char="
 373                           (www-uri-encode-object
 374                            (www-uri-decode-object
 375                             'character (match-string 1 target)))
 376                           (substring target ret))))
 377           (setq target
 378                 (mapcar (lambda (cell)
 379                           (if (string-match "=" cell)
 380                               (progn
 381                                 (setq genre (substring cell 0 (match-beginning 0))
 382                                       ret (substring cell (match-end 0)))
 383                                 (cons
 384                                  (intern
 385                                   (decode-uri-string genre 'utf-8-mcs-er))
 386                                  ret))
 387                             (list (decode-uri-string cell 'utf-8-mcs-er))))
 388                         (split-string target "&")))
 389           (setq ret (car target))
 390           (cond ((eq (car ret) 'char)
 391                  (est-rdf-display-object-desc
 392                   'character
 393                   (cdr ret)
 394                   lang nil)
 395                  )
 396                 ((eq (car ret) 'feature)
 397                  (est-rdf-display-feature-desc
 398                   (decode-uri-string (cdr ret) 'utf-8-mcs-er)
 399                   (car (nth 1 target))
 400                   (cdr (nth 1 target))
 401                   lang
 402                   (eq mode 'simple))
 403                  )
 404                 (t
 405                  (est-rdf-display-object-desc
 406                   (car ret)
 407                   (cdr ret)
 408                   lang nil)
 409                  ))
 410           ))
 411         (princ "</rdf:RDF>")
 412         )
 413     (error nil
 414            (princ (format "%S" err)))
 415     ))
 416
 417 (provide 'cwiki-view)