New Upstream Release - cl-xmls
Ready changes
Summary
Merged new upstream version: 3.2.0 (was: 3.0.2).
Resulting package
Built on 2022-12-14T13:15 (took 4m28s)
The resulting binary packages can be installed (if you have the apt repository enabled) by running one of:
apt install -t fresh-releases cl-xmls
Diff
diff --git a/.github/workflows/main.yml b/.github/workflows/main.yml
new file mode 100644
index 0000000..d73fb38
--- /dev/null
+++ b/.github/workflows/main.yml
@@ -0,0 +1,68 @@
+name: CI
+
+# Controls when the action will run.
+on:
+ # Triggers the workflow on push or pull request events but only for the master branch
+ push:
+ branches: [ master ]
+ pull_request:
+ branches: [ master ]
+
+ # Allows you to run this workflow manually from the Actions tab
+ workflow_dispatch:
+
+# A workflow run is made up of one or more jobs that can run sequentially or in parallel
+jobs:
+ test:
+ # The type of runner that the job will run on
+ runs-on: ${{matrix.os}}
+
+ strategy:
+ matrix:
+ os: [ubuntu-latest]
+ lisp:
+ - ccl
+ - sbcl
+ # - allegro Allegro from Roswell can't load FiveAM from quicklisp
+ - ecl
+ - cmu
+ # - clisp clisp install from Roswell does not work.
+ # - mkcl Tests not implemented on mkcl
+ # - abcl ABCL install from Roswell does not work
+
+ steps:
+ - uses: actions/checkout@v2
+
+ - name: Checkout submodules
+ shell: bash
+ run: |
+ git submodule update --init --recursive
+
+ # Lisp setup copied from here: https://github.com/3b/ci-example/blob/master/.github/workflows/CI.yml
+ - name: cache .roswell
+ id: cache-dot-roswell
+ uses: actions/cache@v1
+ with:
+ path: ~/.roswell
+ key: ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-${{ hashFiles('**/*.asd') }}
+ restore-keys: |
+ ${{ runner.os }}-dot-roswell-${{ matrix.lisp }}-
+ ${{ runner.os }}-dot-roswell-
+
+ - name: install roswell
+ shell: bash
+ # always run install, since it does some global installs and setup that isn't cached
+ env:
+ LISP: ${{ matrix.lisp }}
+ # Use a previous release of Roswell to avoid error encountered
+ # due to libcurl3 not being available.
+ # Source of fix: https://github.com/avodonosov/drakma/commit/fbba29181ba2962f5031da581bd2de4dac98733d
+ run: |
+ sudo apt-get install -y libcurl4
+ curl -L https://raw.githubusercontent.com/roswell/roswell/a8fd8a3c33078d6f06e6cda9d099dcba6fbefcb7/scripts/install-for-ci.sh | sh
+
+ # Compile first in a separate step to make the test output more readable
+ - name: tests
+ shell: bash
+ run: |
+ ros -S `pwd`/:: -l run-tests.lisp
diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..9bea433
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+
+.DS_Store
diff --git a/Changelog b/Changelog
index 64d4389..91050a0 100644
--- a/Changelog
+++ b/Changelog
@@ -1,4 +1,12 @@
-# $Id: Changelog 2269 2016-06-17 19:16:18Z mboldt $
+# $Id$
+
+3.2
+ * Add XMLS/octets to handle character encodings. Many thanks to
+ Daniel Eliason for contributing this.
+
+3.1
+ * Fix namespacing issue (Github #5) on attributes. Thanks to David
+ A. Thompson.
1.8
* Added optional error suppression when items aren't found.
diff --git a/Makefile b/Makefile
index 7e18910..abba7a1 100644
--- a/Makefile
+++ b/Makefile
@@ -20,8 +20,7 @@ TARBALL := "build/${XMLSDIR}.tar.gz"
archive: ;
mkdir -p build
- svn export . build/$(XMLSDIR)
- tar zcf ${TARBALL} -C build $(XMLSDIR)
+ git archive --output ${TARBALL} --prefix 'xmls/' HEAD
gpg -o ${TARBALL}.asc --sign ${TARBALL}
md5sum --binary ${TARBALL} > ${TARBALL}.md5
@@ -30,6 +29,7 @@ publish-archive:
$(eval GPGSIG := ${TARBALL}.asc)
$(eval MD5SUM := ${TARBALL}.md5)
rsync --times --chmod=a+rX,ug+w ${TARBALL} ${GPGSIG} ${MD5SUM} ${website}
+ ssh common-lisp.net "cd ${webhome_dir}; ln -sf ${TARBALL} latest.tar.gz; ln -sf ${GPGSIG} latest.tar.gz.asc; ln -sf ${MD5SUM} latest.tar.gz.md5;"
# must be done after archive
publish-latest:
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..fb4bd25
--- /dev/null
+++ b/README.md
@@ -0,0 +1,226 @@
+# XMLS
+
+<center>Manual For Version 3.1</center>
+
+## Summary
+
+Xmls is a small, simple, non-validating xml parser for Common Lisp. It's designed to be a self-contained, easily embedded parser that recognizes a useful subset of the XML spec. It provides a simple mapping from xml to lisp structures or s-expressions and back.
+
+Since XMLS was first released it has gained some additional complications/features. In particular:
+
+* **Now XMLS by default parses XML documents into lisp structures, rather than s-expressions.** This makes accessing the structures simpler and more reliable. See [section on backward compatibility](#Compatibility).
+* We have added clearly named accessors to further improve extraction of information from parsed XML.
+* Thanks to Max Rottenkolber, we now have the affiliated library, [`xmls/octets`](#octets) that will open streams for the XMLS parser, processing any content-type declarations in the process.
+
+## Features
+
+* Free (BSD license).
+* Understands enough of the xml spec to parse many common documents, including those occurring in common internet protocols like xml-rpc, webdav, and BEEP. Parses 85 out of the 98 valid documents in the oasis parser compliance suite.
+* Small and easily embedded. The entire parser is contained in one file and it's currently less than 600 lines of code. Xmls is written in pure lisp and requires no external parsing tools or foreign libraries.
+* Supports xml namespaces.
+* Threadsafe.
+* Serializes s-expr list structures back to xml as well as parsing xml.
+
+## Limitations
+
+* Parses entire document into memory and consequently can't handle large documents.
+* No detailed error reporting.
+* Hand-built LR parser, meaning the parser structure is a little hard to understand, and can be hard to modify. Use of CL-YACC or similar might be a preferable route for a rewrite.
+
+## XML Representation
+
+Parsed xml is represented as a nested lisp structure, unlike in the original version, where it was a lisp list. The s-expression representation is still maintained, and there are [functions to translate to and from this notation](#translators).
+
+### XML representation as lisp structures
+
+In the structure representation, a node, corresponding to an XML element, is defined as follows:
+
+<pre>(defstruct (node (:constructor %make-node))
+ name
+ ns
+ attrs
+ children)</pre>
+
+XMLS also includes a helper function, `make-node` for creating xml nodes of this form:
+
+<pre>(make-node &key name ns attrs children)
+</pre>
+
+Xmls provides the corresponding accessor functions node-name, node-ns node-attrs, and node-children.
+
+### XML representation as s-expressions
+
+In the s-expression representation, a node is represented as follows:
+
+<pre>(name (attributes) children*)
+</pre>
+
+A name is either a simple string, if the element does not belong to a namespace, or a list of (name namespace-url) if the element does belong to a namespace.
+
+Attributes are stored as `(name value)` lists, with optional properties after the value for `(name value . plist)`. At present, the only property used is `:attr-ns`, the namespace on the attribute, if any. If there is no namespace, the attribute may not be present.
+
+Children are stored as a list of either element nodes or text nodes.
+
+For example, the following xml document:
+
+```
+<?xml version="1.0"?>
+<!-- test document -->
+<book title='The Cyberiad'>
+ <!-- comment in here -->
+ <author xmlns='http://authors'>Stanislaw Lem</author>
+ <info:subject xmlns:info='http://bookinfo' rank='1'>"Cybernetic Fables"</info:subject>
+</book>
+```
+
+Would parse as:
+
+```
+("book" (("title" "The Cyberiad"))
+ (("author" . "http://authors") NIL "Stanislaw Lem")
+ (("subject" . "http://bookinfo") (("rank" "1")) "\"Cybernetic Fables\""))
+```
+
+<a name="Compatibility">
+
+### Backward Compatibility
+
+</a>
+
+To detect whether in this version of XMLS the return value of `PARSE` will be a list or a structure, check for the feature `:XMLS-NODES-ARE-STRUCTS`.
+
+For old code that wants XML parsed into lists, instead of structures, you may replace calls to `(parse str)` with `(node->nodelist (parse str))`.
+
+For greater convenience, we offer `PARSE-TO-LIST`, which performs the same function.
+
+## Usage
+
+The interface is straightforward. The two main functions are `PARSE` and `TOXML`.
+
+<pre>(parse source &key (compress-whitespace t) (quash-errors t)
+</pre>
+
+Parse accepts either a string or an input stream (`source`) and attempts to parse the XML document contained therein. It will return the parse tree as a structure if it's successful or `nil` if parsing fails.
+
+If `COMPRESS-WHITESPACE` is non-`NIL`, content nodes will be trimmed of whitespace and empty whitespace strings between nodes will be discarded.
+
+<pre>(parse-to-list source (&rest args))
+</pre>
+
+Functions as `PARSE`, but returns a list representation of the XML document, instead of a structure.
+
+<pre>(write-prologue xml-decl doctype stream)
+</pre>
+
+`write-prologue` writes the leading `<?xml ... ?>` and `<!DOCTYPE ... >` elements to `stream`. `xml-decl` is an alist of attribute name, value pairs. Valid xml-decl attributes per the xml spec are "version", "encoding", and "standalone", though `write-prologue` does not verify this. `doctype` is a string containing the document type definition.
+
+<pre>(write-prolog xml-decl doctype stream)
+</pre>
+
+U.S. spelling alternative to `write-prologue`.
+
+<pre>(write-xml xml stream &key (indent nil))
+</pre>
+
+`write-xml` accepts a lisp list in the format described above and writes the equivalent xml string to stream. Currently, if nodes use namespaces XMLS will not assign namespaces prefixes but will explicitly assign the namespace to each node. This will be changed in a later release. XMLS will indent the generated xml output if `indent` is non-nil.
+
+<pre>(toxml node &key (indent nil))
+</pre>
+
+`TOXML` is a convenience wrapper around `write-xml` that returns the in a newly allocated string.
+
+<a name="translators">
+
+### Translating to and from s-expressions
+
+</a>
+
+XMLS provides two exported functions to translate between the CL structure representation of the XML tree and the s-expression representation:
+
+<dl>
+
+<dt><code>node->nodelist (<i>node</i>)</code></dt>
+
+<dd>Translate the structure representation into s-expressions.</dd>
+
+<dt><code>nodelist->nodes (<i>xmls-sexp</i>)</code></dt>
+
+<dd>Translate the s-expression representation of an XMLS parse tree into lisp structures.</dd>
+
+</dl>
+
+### Helper functions
+
+These are intended to allow programmers to avoid direct manipulation of the XMLS element representation. If you use these, your code should be easier to read and you will avoid problems if there is a change in internal representation (such changes would be hard to even find, much less correct, if using the lists directly).
+
+<dl>
+
+<dt><code>make-xmlrep (<i>tag</i> &key <i>attribs</i> <i>children</i>)</code></dt>
+
+<dd>Constructor function.</dd>
+
+<dt><code>xmlrep-add-child! (<i>xmlrep</i> <i>child</i>)</code></dt>
+
+<dd>Add a new child node to the XMLREP node.</dd>
+
+<dt><code>xmlrep-tag (<i>xmlrep</i>)</code></dt>
+
+<dd>Extract the tag from XMLREP.</dd>
+
+<dt><code>xmlrep-tagmatch (<i>tag</i> <i>treenode</i>)</code></dt>
+
+<dd>Returns true if TAG is the tag of TREENODE. Match is case _insensitive_ (quite possibly this is the Wrong Thing).</dd>
+
+<dt><code>xmlrep-attribs (<i>xmlrep</i>)</code></dt>
+
+<dd>Extract the attributes from an XMLREP node.</dd>
+
+<dt><code>xmlrep-children (<i>xmlrep</i>)</code></dt>
+
+<dd>Extract the children from an XMLREP node.</dd>
+
+<dt><code>xmlrep-find-child-tags (<i>tag</i> <i>treenode</i>)</code></dt>
+
+<dd>Return all of the (direct) children of <i>treenode</i> whose tags are <i>tag</i>. Matching done by [`xmlrep-tagmatch`](#xmlrep-tagmatch).</dd>
+
+<dt><code>xmlrep-find-child-tag (<i>tag</i> <i>treenode</i> &optional (<i>if-unfound</i> :error))</code></dt>
+
+<dd>Find a _single_ child of <i>treenode</i> with <i>tag</i>. Returns an error if there is more or less than one such child.</dd>
+
+<dt><code>xmlrep-string-child (<i>treenode</i> &optional (<i>if-unfound</i> :error))</code></dt>
+
+<dd>Returns the _single_ string-valued child of <i>treenode</i>. If there is more than one child, or if a single child is not a simple value, returns <i>if-unfound</i>, which defaults to <code>:ERROR</code>.</dd>
+
+<dt><code>xmlrep-integer-child (<i>treenode</i>)</code></dt>
+
+<dd>Find the _single_ child of <i>treenode</i> whose value is a string that can be parsed into an integer. Returns an error if there is more than one child, or if a single child is not appropriately valued.</dd>
+
+<dt><code>xmlrep-attrib-value (<i>attrib</i> <i>treenode</i> &optional (<i>if-undefined</i> :error))</code></dt>
+
+<dd>Find the value of <i>attrib</i>, a string, in <i>treenode</i>. if there is no <i>attrib</i>, will return the value of <i>if-undefined</i>, which defaults to <code>:ERROR</code>.</dd>
+
+<dt><code>xmlrep-boolean-attrib-value (<i>attrib</i> <i>treenode</i> &optional (<i>if-undefined</i> :error))</code></dt>
+
+<dd>Find the value of <i>attrib</i>, a string, in <i>treenode</i>. The value should be either "true" or "false". The function will return <code>T</code> or <code>NIL</code>, accordingly. If there is no <i>attrib</i>, will return the value of <i>if-undefined</i>, which defaults to <code>:ERROR</code>.</dd>
+
+</dl>
+
+<a name="octets">
+
+## XMLS/Octets
+
+</a>
+
+XMLS itself simply processes strings or streams. This means that it does not provide native support for handling character encodings, as declared in the XML headers. The system `xmls/octets`, which depends on `xmls` provides that support with the exported function `make-xml-stream`, which takes an octet-stream as argument, processes its header, choosing the appropriate character encoding, and then returns a stream suitable for passing to `xmls:parse`.
+
+Probably `make-xml-stream` should be made generic, and support arguments of other types (e.g., strings interpreted as filenames, pathnames, etc.).
+
+## Installation
+
+XMLS can be installed as an ASDF system. An ASDF system definition is provided with the distribution.
+
+Previous versions of XMLS were single files, and could be installed simply by loading the file xmls.lisp. This option is no longer supported.
+
+## Contact Information
+
+Please post issues in the [GitHub Repository](https://github.com/rpgoldman/xmls/issues)
diff --git a/debian/changelog b/debian/changelog
index b84d13c..730d321 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,10 +1,11 @@
-cl-xmls (3.0.2-2) UNRELEASED; urgency=medium
+cl-xmls (3.2.0-1) UNRELEASED; urgency=medium
* Trim trailing whitespace.
* Bump debhelper from old 12 to 13.
* Update standards version to 4.5.1, no changes needed.
+ * New upstream release.
- -- Debian Janitor <janitor@jelmer.uk> Tue, 07 Sep 2021 19:33:29 -0000
+ -- Debian Janitor <janitor@jelmer.uk> Wed, 14 Dec 2022 13:11:28 -0000
cl-xmls (3.0.2-1) unstable; urgency=medium
diff --git a/extract-path.lisp b/extract-path.lisp
new file mode 100644
index 0000000..59cd6a1
--- /dev/null
+++ b/extract-path.lisp
@@ -0,0 +1,123 @@
+;; (declaim (optimize (speed 0) (space 0) (debug 3) (safety 3) (compilation-speed 0)))
+
+(in-package :xmls)
+
+;; XML extraction tool
+
+(defun extract-path ( key-list xml )
+ "Extracts data from XML parse tree. KEY-LIST is a path for descending down
+named objects in the XML parse tree. For each KEY-LIST element, XML subforms
+are searched for a matching tag name. Finally the whole last XML subform on the
+path is normally returned if found; however the symbol * may be added at the end
+of KEY-LIST to return list of all objects /enclosed/ by the last subform on
+KEY-LIST. Also KEY-LIST may be dotted as explained below to return XML tag
+attributes from the last subform on KEY-LIST.
+
+XML is to have the forms as returned by PARSE-TO-LIST or PARSE:
+ (tag-name (attributes-list) subform*),
+ ((tag-name . name-space) (attributes-list) subform*), or
+ #s(node :name tag-name
+ :ns name-space
+ :attrs attributes-list
+ :children subform*)
+
+The first element in KEY-LIST must match the top level form in XML.
+Subsequently each element in the KEY-LIST is to match a subform.
+
+An element of KEY-LIST may be a string atom. In that case the first subform
+with tag-name matching the string is matched. An element of KEY-LIST may also
+be a list of string atoms in this format:
+ (tag-name (attribute-name attribute-value) ...)
+
+The first subform with name matching TAG-NAME /and/ having attributes matching
+attribute-names and attribute-values is matched. Zero or more attribute/value
+pairs may be given.
+
+Normally the whole subform matching last element in KEY-LIST is returned. The
+symbol * can be the last element of KEY-LIST to return list of all subforms
+enclosed by the last matched form. Attributes of last matched subform may be
+searched by ending KEY-LIST in dot notation, in which case the string after dot
+matches an attribute name. The two element list of attribute name and value is
+returned. The symbol * may be used after dot to return the whole attribute list.
+
+In the case where the search fails NIL is returned. However it is possible that
+the search partially succeeds down the key path. Three values are returned
+altogether and the 2nd and 3rd values give information about how much of
+KEY-LIST was matched, and at what point in XML:
+ (values RESULT KEY-LIST-FRAGMENT XML-FRAGMENT)
+
+When RESULT is non-NIL, the others are NIL. When result is NIL however, the
+others are:
+ XML-FRAGMENT
+ The last XML form that /did/ match in the key list. It matches the first
+ element of KEY-LIST-FRAGMENT.
+
+ KEY-LIST-FRAGMENT
+ The /remaining/ part of the KEY-LIST that did not succeed. However the
+ /first/ item on KEY-LIST-FRAGMENT matches the XML-FRAGMENT returned. The
+ failure is at the second item on KEY-LIST-FRAGMENT.
+
+In the case of complete failure, where even the very first item on KEY-LIST does not
+match the top XML form given, all three return values are NIL. (It suffices to check
+the first two return values.)"
+ (labels ((attribs-match-p ( key-attribs-list xml-attribs-list )
+ ;; search for (attr-name attr-value) pairs from KEY-ATTRIBS-LIST on
+ ;; XML-ATTRIBS-LIST. true if all key pairs found.
+ (loop
+ :with attribs-match-var := t
+ :for attrib-key-pair :in key-attribs-list
+ :do
+ (setq attribs-match-var
+ (and attribs-match-var
+ (find attrib-key-pair xml-attribs-list :test #'equal)))
+ :finally (return attribs-match-var)))
+
+ (find-test ( key xml-form )
+ ;; test whether the XML-FORM matches KEY
+ (cond
+ ;; just the XML tag name in key
+ ;; XML name is simple string
+ ((and (stringp key)
+ (stringp (xmlrep-tag xml-form)))
+ (string-equal key (xmlrep-tag xml-form)))
+
+ ;; key form (tag-name (attr-name attr-value) ...)
+ ((and (find-test (car key) xml-form)
+ (attribs-match-p (cdr key) (xmlrep-attribs xml-form))))))
+
+ (descend ( key-list xml-form )
+ ;; recursive run down KEY-LIST. If XML-FORM runs down to NIL before reaching
+ ;; the end of KEY-LIST, it will be NIL at the end. If not, what is
+ ;; remaining of XML-FORM is the found item.
+ (cond
+ ;; KEY-LIST ends without dotted item, at the target XML form
+ ((null (cdr key-list))
+ (values xml-form nil nil))
+
+ ;; dotted item at the end of KEY-LIST, search attribute list of target XML form
+ ((atom (cdr key-list))
+ (if (eq '* (cdr key-list))
+ (values (xmlrep-attribs xml-form) nil nil)
+ (find (cdr key-list) (xmlrep-attribs xml-form)
+ :test (lambda (key item) (equal key (car item))))))
+
+ ;; more tag names to match on KEY-LIST
+ ('t
+ (if (eq '* (cadr key-list))
+ (values (xmlrep-children xml-form) nil nil)
+ (let ((selected-xml-form (find (cadr key-list) (xmlrep-children xml-form)
+ :test #'find-test)))
+ (if selected-xml-form
+ (descend (cdr key-list) selected-xml-form)
+
+ ;; no matching sub-form, indicate what part of KEY-LIST did not match
+ (values nil key-list xml-form))))))))
+
+ ;; empty list, degenerate usage
+ (when (null key-list)
+ (error "KEY-LIST is empty."))
+
+ ;; search down after initial match
+ (if (find-test (car key-list) xml)
+ (descend key-list xml)
+ (values nil nil nil))))
diff --git a/fiveam-tests.lisp b/fiveam-tests.lisp
index 4e6419d..214631a 100644
--- a/fiveam-tests.lisp
+++ b/fiveam-tests.lisp
@@ -1,3 +1,5 @@
+;; (declaim (optimize (speed 0) (space 0) (debug 3) (safety 3) (compilation-speed 0)))
+
(in-package :common-lisp-user)
(defpackage xmls-test
(:use :common-lisp :fiveam :xmls)
@@ -48,3 +50,106 @@
(is (equal (list "profile" "profile" "profile")
(mapcar #'xmlrep-tag (xmlrep-children node))))))
+(test attribute-with-prefixed-name
+ (is (string= "style"
+ (getf (xmls::find-attrib "name"
+ (xmls:parse "<?xml version=\"1.0\"?> <text:list-style style:name=\"L1\"></text:list-style>"))
+ :attr-ns))))
+
+(def-fixture article-parsed-as-list ()
+ (let ((parse-tree
+ (with-open-file (str (asdf:system-relative-pathname "xmls" "tests/nxml/genetics-article.xml")
+ :direction :input)
+ (xmls:parse-to-list str))))
+ (&body)))
+
+(test check-extract-path-from-list-nodes
+ (with-fixture article-parsed-as-list ()
+ ;; retrieve first of items matching the path
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" "ref")
+ parse-tree)))
+ (is (= 4 (length result)))
+ (is (equalp (nth 0 result)
+ '("ref" . "http://dtd.nlm.nih.gov/2.0/xsd/archivearticle")))
+ (is (equalp (nth 1 result)
+ '(("id" "gkt903-B1")))))
+
+ ;; retrieve tag attributes of first item matching the path
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" "ref" . *)
+ parse-tree)))
+ (is (equalp result
+ '(("id" "gkt903-B1")))))
+
+ ;; retrieve all items enclosed by element matching the path
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" *)
+ parse-tree)))
+ (is (= 41 (length result)))
+ (is (equalp (nth 0 result)
+ '(("title" . "http://dtd.nlm.nih.gov/2.0/xsd/archivearticle") nil "REFERENCES")))
+ (is (equalp (nth 1 (nth 1 result))
+ '(("id" "gkt903-B1"))))
+ (is (equalp (nth 1 (nth 15 result))
+ '(("id" "gkt903-B15")))))
+
+ ;; select specific item among several with same tag based on tag attributes
+ ;; here selecting on "ref" in the path...
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" ("ref" ("id" "gkt903-B15")) "element-citation"
+ "article-title")
+ parse-tree)))
+ (is (equalp result
+ '(("article-title" . "http://dtd.nlm.nih.gov/2.0/xsd/archivearticle") NIL
+ "HNS, a nuclearcytoplasmic shuttling sequence in HuR"))))))
+
+(def-fixture article-parsed-as-struct ()
+ (let ((parse-tree
+ (with-open-file (str (asdf:system-relative-pathname "xmls" "tests/nxml/genetics-article.xml")
+ :direction :input)
+ (xmls:parse str))))
+ (&body)))
+
+(test check-extract-path-from-struct-nodes
+ (with-fixture article-parsed-as-struct ()
+ ;; retrieve first of items matching the path
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" "ref")
+ parse-tree)))
+ (is (string= (node-name result) "ref"))
+ (is (string= (node-ns result) "http://dtd.nlm.nih.gov/2.0/xsd/archivearticle"))
+ (is (equalp (node-attrs result) '(("id" "gkt903-B1")))))
+
+ ;; retrieve tag attributes of first item matching the path
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" "ref" . *)
+ parse-tree)))
+ (is (equalp result '(("id" "gkt903-B1")))))
+
+ ;; retrieve all items enclosed by element matching the path
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" *)
+ parse-tree)))
+ (is (= 41 (length result)))
+ (is (equalp (nth 0 result)
+ (make-node :name "title"
+ :ns "http://dtd.nlm.nih.gov/2.0/xsd/archivearticle"
+ :attrs nil
+ :children '("REFERENCES"))))
+ (is (equalp (node-attrs (nth 1 result))
+ '(("id" "gkt903-B1"))))
+ (is (equalp (node-attrs (nth 15 result))
+ '(("id" "gkt903-B15")))))
+
+ ;; select specific item among several with same tag based on tag attributes
+ ;; here selecting on "ref" in the path...
+ (let ((result (xmls:extract-path '("OAI-PMH" "GetRecord" "record" "metadata" "article"
+ "back" "ref-list" ("ref" ("id" "gkt903-B15")) "element-citation"
+ "article-title")
+ parse-tree)))
+ (is (equalp result
+ (make-node :name "article-title"
+ :ns "http://dtd.nlm.nih.gov/2.0/xsd/archivearticle"
+ :attrs NIL
+ :children '("HNS, a nuclearcytoplasmic shuttling sequence in HuR")))))))
diff --git a/run-tests.lisp b/run-tests.lisp
index 6bdbe5d..f5e846e 100644
--- a/run-tests.lisp
+++ b/run-tests.lisp
@@ -3,10 +3,15 @@
(in-package :xmls-test-runner)
+(defun featurep (x)
+ (member x *features* :test 'eq))
+
(require :asdf)
(format t "ASDF version is ~a~%" (asdf:asdf-version))
-(defparameter *quicklisp-p* (not (zerop (parse-integer (uiop:getenv "QUICKLISP")))) )
-(when *quicklisp-p*
+(defparameter *quicklisp-p* (or (featurep :quicklisp)
+ (not (zerop (parse-integer (uiop:getenv "QUICKLISP"))))) )
+;; Roswell puts its quicklip set up in a different place.
+(when (and *quicklisp-p* (not (featurep :ros.init)))
(load (merge-pathnames "quicklisp/setup.lisp"
(user-homedir-pathname))))
(defmacro quit-on-error (&body body)
diff --git a/version.lisp-expr b/version.lisp-expr
index 1b137dc..65640cc 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -1 +1 @@
-"3.0.2"
+"3.2.0"
diff --git a/web-page/clnet-page.shtml b/web-page/clnet-page.shtml
index 7763cc5..485183a 100644
--- a/web-page/clnet-page.shtml
+++ b/web-page/clnet-page.shtml
@@ -17,8 +17,17 @@ PUBLIC "-//W3C//DTD XHTML 1.1 Strict//EN"
<table>
<tr>
- <td><span style="color: red">latest --></span> Better backwards
- compatibility (see manual for details). Additional export over 3.0.1</td>
+
+
+ <td><span style="color: red">latest --></span> Preserve namespacing in attribute names.</td>
+ <td>xmls-3.1.0</td>
+ <td><a href="xmls-3.1.0.tar.gz">source</a></td>
+ <td><a href="xmls-3.1.0.tar.gz.asc">signature</a></td>
+ <td><a href="xmls-3.1.0.tar.gz.md5">md5</a></td>
+ </tr>
+
+ <tr>
+ <td> </td>
<td>xmls-3.0.2</td>
<td><a href="xmls-3.0.2.tar.gz">source</a></td>
<td><a href="xmls-3.0.2.tar.gz.asc">signature</a></td>
@@ -27,8 +36,8 @@ PUBLIC "-//W3C//DTD XHTML 1.1 Strict//EN"
<!-- <td><a href="latest/Changelog">changelog</a></td> -->
</tr>
- <td>Better backwards
- compatibility (see manual for details).</td>
+ <tr>
+ <td> </td>
<td>xmls-3.0.1</td>
<td><a href="xmls-3.0.1.tar.gz">source</a></td>
<td><a href="xmls-3.0.1.tar.gz.asc">signature</a></td>
@@ -109,13 +118,8 @@ PUBLIC "-//W3C//DTD XHTML 1.1 Strict//EN"
<h2>Source repository</h2>
-<p>There is no publicly-accessible source repository for XMLS. Please submit
-patches to the maintainer. The likelihood of getting patches doesn't justify
-the effort of maintaining such a source repository. If this is a real problem
-for you, please contact the maintainer and we will arrange to provide you access to
-the private repository.</p>
-
- <!--#include virtual="latest/README.html" -->
+<p>The source repository is now available on GitHub: <a
+href="https://github.com/rpgoldman/xmls">xmls</a>.</p>
</body>
diff --git a/xmlrep-helpers.lisp b/xmlrep-helpers.lisp
index 58e501e..79b5c7d 100644
--- a/xmlrep-helpers.lisp
+++ b/xmlrep-helpers.lisp
@@ -10,34 +10,73 @@
;;; [2004/09/15:Robert P. Goldman] Created.
;;;
;;;---------------------------------------------------------------------------
-(in-package :xmls)
-
-(defun make-xmlrep (tag &key attribs children)
- (make-node :name tag :attrs attribs :children children))
+;; (declaim (optimize (speed 0) (space 0) (debug 3) (safety 3) (compilation-speed 0)))
-(defun xmlrep-add-child! (xmlrep child)
- (setf (node-children xmlrep)
- (append (node-children xmlrep)
- (list child))))
+(in-package :xmls)
-(defun xmlrep-tag (treenode)
- (node-name treenode))
+(defun make-xmlrep (tag &key (representation-kind :node) namespace attribs children)
+ (case representation-kind
+ ((:list)
+ (cond
+ (namespace
+ (list (list tag namespace) (list attribs) children))
+ (t
+ (list tag (list attribs) children))))
+ ((:node)
+ (make-node :name tag :ns namespace :attrs attribs :children children))
+ (otherwise
+ (error "REPRESENTATION-KIND must be :LIST or :NODE, found ~s" representation-kind))))
+
+(defgeneric xmlrep-add-child! (xmlrep child)
+ (:method ((xmlrep node) child)
+ (setf (node-children xmlrep)
+ (append (node-children xmlrep)
+ (list child))))
+ (:method ((xmlrep cons) child)
+ (setf (cddr xmlrep)
+ (append (cddr xmlrep)
+ (list child)))))
+
+(defgeneric xmlrep-tag (treenode)
+ (:method ((treenode node))
+ (node-name treenode))
+ (:method ((treenode cons))
+ (let ((tag-name (car treenode)))
+ ;; detect the "namespaced" case
+ (cond
+ ((consp tag-name) (car tag-name))
+ (t tag-name)))))
(defun xmlrep-tagmatch (tag treenode)
- (unless (stringp treenode) ; child nodes to XMLREPs could be strings or nodes
+ ;;child nodes to XMLREPs could be strings or nodes
+ (unless (stringp treenode)
(string-equal tag (xmlrep-tag treenode))))
-(defun xmlrep-attribs (treenode)
- (node-attrs treenode))
-
-(defun (setf xmlrep-attribs) (attribs treenode)
- (setf (node-attrs treenode) attribs))
-
-(defun xmlrep-children (treenode)
- (node-children treenode))
-
-(defun (setf xmlrep-children) (children treenode)
- (setf (node-children treenode) children))
+(defgeneric xmlrep-attribs (treenode)
+ (:method ((treenode node))
+ (node-attrs treenode))
+ (:method ((treenode cons))
+ (cadr treenode)))
+
+(defgeneric (setf xmlrep-attribs) (attribs treenode)
+ (:argument-precedence-order treenode attribs)
+ (:method (attribs (treenode node))
+ (setf (node-attrs treenode) attribs))
+ (:method (attribs (treenode cons))
+ (setf (cadr treenode) attribs)))
+
+(defgeneric xmlrep-children (treenode)
+ (:method ((treenode node))
+ (node-children treenode))
+ (:method ((treenode cons))
+ (cddr treenode)))
+
+(defgeneric (setf xmlrep-children) (children treenode)
+ (:argument-precedence-order treenode children)
+ (:method (children (treenode node))
+ (setf (node-children treenode) children))
+ (:method (children (treenode cons))
+ (setf (cddr treenode) children)))
(defun xmlrep-string-child (treenode &optional (if-unfound :error))
(let ((children (xmlrep-children treenode)))
diff --git a/xmls.asd b/xmls.asd
index 9b6b27d..22c55ff 100644
--- a/xmls.asd
+++ b/xmls.asd
@@ -1,5 +1,5 @@
;;; -*- Lisp -*-
-;;; $Id: xmls.asd 2399 2017-12-17 22:55:24Z rpgoldman $
+;;; $Id$
(defpackage #:xmls-system (:use #:cl #:asdf))
(in-package :xmls-system)
@@ -26,18 +26,22 @@
#+asdf-unicode :encoding #+asdf-unicode :utf-8)
(:file "xmlrep-helpers"
;; package is defined in XMLS. [2009/02/24:rpg]
+ :depends-on ("xmls"))
+ (:file "extract-path"
:depends-on ("xmls"))))
(defsystem :xmls/test
:perform (test-op (op c)
(declare (ignorable op c))
+ #-(or sbcl cmu allegro abcl ccl clisp ecl)
+ (error "Test OP for XMLS not supported on this lisp implementation.")
(unless
(uiop:symbol-call :xmls :test :interactive t)
(error "Failed XMLS test.")))
:depends-on (xmls))
-(defsystem xmls/unit-test
- :depends-on (xmls fiveam)
+(defsystem :xmls/unit-test
+ :depends-on (xmls fiveam)
:perform (test-op (op c)
(declare (ignorable op c))
(uiop:symbol-call :fiveam :run! (uiop:find-symbol* '#:xmls-test :xmls-test)))
diff --git a/xmls.lisp b/xmls.lisp
index f4e6cad..683a5c5 100644
--- a/xmls.lisp
+++ b/xmls.lisp
@@ -1,4 +1,4 @@
-;;; $Id: xmls.lisp 2400 2017-12-18 00:17:36Z rpgoldman $
+;;; $Id$
;;; xmls
;;; a simple xml parser for common lisp
;;; author: Miles Egan <miles@caddr.com>
@@ -31,6 +31,10 @@
xmlrep-attrib-value
xmlrep-boolean-attrib-value
+ ;; tree searching from Daniel Eliason
+ extract-path-list
+ extract-path
+
;;debugging
debug-on debug-off))
@@ -44,18 +48,19 @@
(defvar *compress-whitespace* t)
(defvar *test-verbose* nil)
(defvar *discard-processing-instructions*)
-(defvar *entities*
- #(("lt;" #\<)
- ("gt;" #\>)
- ("amp;" #\&)
- ("apos;" #\')
- ("quot;" #\")))
+
(eval-when (:compile-toplevel :load-toplevel :execute)
+ (declaim (type vector *entities*))
+ (defvar *entities*
+ #(("lt;" #\<)
+ ("gt;" #\>)
+ ("amp;" #\&)
+ ("apos;" #\')
+ ("quot;" #\")))
(defvar *whitespace* (remove-duplicates
'(#\Newline #\Space #\Tab #\Return #\Linefeed))))
(defvar *char-escapes*
(let ((table (make-array 256 :element-type 'string :initial-element "")))
- (declare (type vector *entities*))
(loop
for code from 0 to 255
for char = (code-char code)
@@ -299,7 +304,6 @@ fixed."
converted using CODE-CHAR, which only works in implementations that
internally encode strings in US-ASCII, ISO-8859-1 or UCS."
(declare (type simple-string ent))
- (declare (type vector *entities*))
(or (and (>= (length ent) 2)
(char= (char ent 0) #\#)
(code-char
@@ -546,8 +550,13 @@ character translation."
(setf val (match* attr-text-sq))
(match #\'))))
t)
- (if (string= "xmlns" name) (list 'nsdecl suffix val) (list
- 'attr (or suffix name) val)))))
+ (if (string= "xmlns" name)
+ (list 'nsdecl suffix val)
+ ;; If SUFFIX is true, then NAME is Prefix and SUFFIX is
+ ;; LocalPart.
+ (if suffix
+ (list 'attr suffix val :attr-ns name)
+ (list 'attr name val))))))
(defrule ws ()
(and (match+ ws-char)
@@ -875,7 +884,7 @@ character translation."
"xml-rpc/methodResponse.xml"
"xml-rpc/struct.xml")))
-#+(or sbcl cmu allegro abcl ccl clisp)
+#+(or sbcl cmu allegro abcl ccl clisp ecl)
(defun test (&key interactive (test-files *test-files*))
"Run the test suite. If it fails, either return NIL \(if INTERACTIVE\),
otherwise exit with an error exit status."
@@ -892,6 +901,7 @@ otherwise exit with an error exit status."
#+cmu (member "--" extensions:*command-line-strings* :test 'equal)
#+allegro (sys:command-line-arguments)
#+clisp ext:*args*
+ #+ecl (ext:command-args)
#+ccl
ccl:*unprocessed-command-line-arguments*)))
(catch 'test-failure
Debdiff
[The following lists of changes regard files as different if they have different names, permissions or owners.]
Files in second set of .debs but not in first
-rw-r--r-- root/root /usr/share/common-lisp/source/xmls/extract-path.lisp
No differences were encountered in the control files