summaryrefslogtreecommitdiff
path: root/lingva.lisp
blob: 15aa663fc811685d681516009bf97a024894051a (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
(in-package #:mulkcms)

(defvar +lang-ns+
    "http://matthias.benkard.de/software/language-markup/1.0")

(defun in-tag-list-p (string tag-list)
  (ppcre:scan (format nil "\\b~A\\b" string) tag-list))


(defun language-filter-sub-xmls (language node)
  (if (listp node)
      (destructuring-bind (name attrs &rest subnodes)
          node
        (let ((langs (find `("langs" . ,+lang-ns+)
                           attrs :key #'first :test #'equal))
              (unlangs (find `("unlangs" . ,+lang-ns+)
                             attrs :key #'first :test #'equal)))
          (if (or (and (null langs) (null unlangs))
                  (and langs   (in-tag-list-p language (second langs)))
                  (and unlangs (not (in-tag-list-p language (second unlangs)))))
              (list (list* name
                           attrs
                           (mapcan (lambda (x)
                                     (language-filter-sub-xmls language x))
                                   subnodes)))
              nil)))
      (list node)))

(defun language-filter-xmls (language node)
  (first (language-filter-sub-xmls language node)))


;; Test:
#+(or)
(defvar *test-xml* "<html xmlns=\"http://www.w3.org/1999/xhtml\" xmlns:m=\"http://matthias.benkard.de/software/language-markup/1.0\">
  <body>
    <h1 m:langs=\"la\">Documentatio</h1>
    <h1 m:langs=\"en fr\">Documentation</h1>
    <h1 m:unlangs=\"la fr en\">Dokumentation</h1>
  </body>
</html>")

#+(or)
(let ((language "la"))                  ;or one of "de", "en", "fr"
  (with-output-to-string (stream)
    (let ((node (cxml:parse *test-xml* (cxml-xmls:make-xmls-builder))))
      (cxml-xmls:map-node (cxml:make-character-stream-sink stream)
                          (language-filter-xmls language node)))))



;; Don't be fooled by the length of this function.  It does
;; significantly more than the xmls version above!
(defun language-filter-stp (language stp)
  (let ((wantp (lambda (node)
                 (or (not (typep node 'stp:element))
                     (stp:with-attributes ((langs   "langs"   +lang-ns+)
                                           (unlangs "unlangs" +lang-ns+))
                         node
                       (or (and (null langs) (null unlangs))
                           (and langs   (in-tag-list-p language langs))
                           (and unlangs (not (in-tag-list-p language unlangs))))))))
        (remove-lang-attributes
         (lambda (node)
                                  
           (when (typep node 'stp:element)
             (let ((langs   (stp:find-attribute-named node "langs"   +lang-ns+))
                   (unlangs (stp:find-attribute-named node "unlangs" +lang-ns+)))
               (when langs
                 (stp:remove-attribute node langs))
               (when unlangs
                 (stp:remove-attribute node unlangs)))))))
    (dolist (unwanted-element (stp:filter-recursively (complement wantp) stp))
      (stp:delete-child unwanted-element (stp:parent unwanted-element)))
    (stp:map-recursively remove-lang-attributes (stp:document-element stp))
    (stp:map-extra-namespaces
     (lambda (prefix uri)
       (when (string= uri +lang-ns+)
         (stp:remove-extra-namespace (stp:document-element stp) prefix)))
     (stp:document-element stp))
    stp))



;; Test:
#+(or)
(let ((language "la"))  ;or one of "de", "en", "fr"
  (with-output-to-string (stream)
    (let ((node (cxml:parse *test-xml* (stp:make-builder))))
      (stp:serialize (language-filter-stp language node)
                     (cxml:make-character-stream-sink stream)))))