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