From e7eb24f3526bd806ace3d9e151e1e3542be2e33c Mon Sep 17 00:00:00 2001 From: Matthias Andreas Benkard Date: Sun, 13 Mar 2011 19:30:09 +0100 Subject: Add missing file lingva.lisp. --- lingva.lisp | 94 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 94 insertions(+) create mode 100644 lingva.lisp 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* " + +

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))))) + + + -- cgit v1.2.3