(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* "
Documentatio
Documentation
Dokumentation
")
#+(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)))))