diff options
| author | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2011-03-13 19:30:09 +0100 |
|---|---|---|
| committer | Matthias Andreas Benkard <code@mail.matthias.benkard.de> | 2011-03-13 19:30:09 +0100 |
| commit | e7eb24f3526bd806ace3d9e151e1e3542be2e33c (patch) | |
| tree | 2d501d238ed2fd02e4f67d43b14a54f9765cf99f /lingva.lisp | |
| parent | 4d8db5450033edf9319b02873f8c75a9ed36dbd1 (diff) | |
Add missing file lingva.lisp.
Diffstat (limited to 'lingva.lisp')
| -rw-r--r-- | lingva.lisp | 94 |
1 files changed, 94 insertions, 0 deletions
diff --git a/lingva.lisp b/lingva.lisp new file mode 100644 index 0000000..15aa663 --- /dev/null +++ b/lingva.lisp @@ -0,0 +1,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))))) + + + |