Mercurial > core / lisp/lib/dat/xml/xml.lisp
changeset 698: |
96958d3eb5b0 |
parent: |
aac665e2f5bf
|
author: |
Richard Westhaver <ellis@rwest.io> |
date: |
Fri, 04 Oct 2024 22:04:59 -0400 |
permissions: |
-rw-r--r-- |
description: |
fixes |
1 ;;; lib/dat/xml.lisp --- XML Data Format 3 ;; based on the re-implementation of https://github.com/rpgoldman/xmls 5 ;; our nodes are called XML-NODE and inherit from OBJ/TREE:NODE. 7 ;; XMLS:NODE-NAME == OBJ/TREE:NODE-KEY 14 ;;;----------------------------------------------------------------------------- 16 ;;;----------------------------------------------------------------------------- 17 (defvar *strip-comments* t) 18 (defvar *compress-whitespace* t) 19 (defvar *discard-processing-instructions*) 21 (eval-when (:compile-toplevel :load-toplevel :execute) 22 (declaim (type vector *entities*)) 29 (defvar *whitespace* (remove-duplicates 30 '(#\Newline #\Space #\Tab #\Return #\Linefeed)))) 31 (defvar *char-escapes* 32 (let ((table (make-array 256 :element-type 'string :initial-element ""))) 34 for code from 0 to 255 35 for char = (code-char code) 36 for entity = (first (find char *entities* :test #'char= :key #'second)) 37 do (setf (svref table code) 40 (concatenate 'string "&" entity)) 41 ((and (or (< code 32) (> code 126)) 44 (format nil "&#x~x;" code)) 46 (format nil "~x" char)))) 47 finally (return table)) 50 ;;;--------------------------------------------------------------------------- 52 ;;;--------------------------------------------------------------------------- 53 (defvar *parser-stream* nil 54 "The currently-being-parsed stream. Used so that we can appropriately track 56 (defvar *parser-line-number* nil) 60 ;;;----------------------------------------------------------------------------- 62 ;;;----------------------------------------------------------------------------- 63 (define-condition xml-parse-error (error) 67 (:report (lambda (xpe stream) 68 (format stream "XML-PARSE-ERROR~@[ at line ~d~]" 71 (defmethod initialize-instance :after ((obj xml-parse-error) &key) 72 (unless (slot-value obj 'line) 73 (when *parser-line-number* 74 (setf (slot-value obj 'line) *parser-line-number*)))) 76 ;;;----------------------------------------------------------------------------- 78 ;;;----------------------------------------------------------------------------- 79 (defstruct (xml-node (:constructor %make-xml-node)) 85 (defun make-xml-node (&key name ns attrs child children) 86 "Convenience function for creating a new xml node." 87 (when (and child children) 88 (error "Cannot specify both :child and :children for MAKE-NODE.")) 89 (let ((children (if child 92 (%make-xml-node :name name :ns ns 96 ;;;--------------------------------------------------------------------------- 97 ;;; XML Processing Instruction 98 ;;;--------------------------------------------------------------------------- 100 (target "" :type string) 101 (contents "" :type string) 105 ;;;----------------------------------------------------------------------------- 106 ;;; UTILITY FUNCTIONS 107 ;;;----------------------------------------------------------------------------- 108 (defun compress-whitespace (str) 109 (if *compress-whitespace* 111 (setf str (string-trim *whitespace* str)) 112 (if (= 0 (length str)) 117 (defun write-escaped (string stream) 118 (write-string (escape-for-html string) stream)) 120 (defun escape-for-html (string) 121 "Escapes the characters #\\<, #\\>, #\\', #\\\", and #\\& for HTML output." 122 (with-output-to-string (out) 123 (with-input-from-string (in string) 124 (loop for char = (read-char in nil nil) 127 ((#\<) (write-string "<" out)) 128 ((#\>) (write-string ">" out)) 129 ((#\") (write-string """ out)) 130 ((#\') (write-string "'" out)) 131 ((#\&) (write-string "&" out)) 132 (otherwise (write-char char out))))))) 134 (defun make-extendable-string (&optional (size 10)) 135 "Creates an adjustable string with a fill pointer." 137 :element-type 'character 141 (defun push-string (c string) 142 "Shorthand function for adding characters to an extendable string." 143 (vector-push-extend c string)) 145 (defun translate-raw-value (raw-value) 146 "Helper function for xml generation." 149 (symbol (symbol-name raw-value)) 150 (integer (format nil "~D" raw-value)) 151 (float (format nil "~G" raw-value)))) 153 (defun generate-xml (e s indent) 154 "Renders a lisp node tree to an xml string stream." 155 (if (> indent 0) (incf indent)) 159 (dotimes (i (* 2 (- indent 2))) 160 (write-char #\Space s)) 161 (format s "<~A~@[ xmlns=\"~A\"~]" (xml-node-name e) (xml-node-ns e)) 162 (loop for a in (xml-node-attrs e) 164 (write-char #\Space s) 165 (write-string (first a) s) 168 (write-escaped (translate-raw-value (second a)) s) 169 (write-char #\" s)))) 170 (if (null (xml-node-children e)) 172 (write-string "/>" s) 173 (if (> indent 0) (write-char #\Newline s))) 176 (if (> indent 0) (write-char #\Newline s)) 177 (mapc #'(lambda (c) (generate-xml c s indent)) (xml-node-children e)) 180 (dotimes (i (* 2 (- indent 2))) 181 (write-char #\Space s)))) 182 (format s "</~A>" (xml-node-name e)) 183 (if (> indent 0) (write-char #\Newline s))))) 185 (generate-xml (translate-raw-value e) s indent)) 187 (generate-xml (translate-raw-value e) s indent)) 192 (dotimes (i (* 2 (- indent 2))) 193 (write-char #\Space s)))) 195 (if (> indent 0) (write-char #\Newline s)))))) 197 ;;;----------------------------------------------------------------------------- 198 ;;; PARSER STATE & LOOKAHEAD 199 ;;;----------------------------------------------------------------------------- 201 "Represents parser state. Passed among rules to avoid threading issues." 203 (lines 1 :type integer) 207 (defun resolve-entity (ent) 208 "Resolves the xml entity ENT to a character. Numeric entities are 209 converted using CODE-CHAR, which only works in implementations that 210 internally encode strings in US-ASCII, ISO-8859-1 or UCS." 211 (declare (type simple-string ent)) 212 (or (and (>= (length ent) 2) 213 (char= (char ent 0) #\#) 215 (if (char= (char ent 1) #\x) 216 (parse-integer ent :start 2 :end (- (length ent) 1) :radix 16) 217 (parse-integer ent :start 1 :end (- (length ent) 1))))) 218 (second (find ent *entities* :test #'string= :key #'first)) 219 (error "Unable to resolve entity ~S" ent))) 221 (declaim (inline peek-stream)) 222 (defun peek-stream (stream) 223 "Looks one character ahead in the input stream. Serves as a potential hook for 224 character translation." 225 (peek-char nil stream nil)) 227 (defun read-stream (stream) 228 "Reads a character from the stream, translating entities as it goes." 229 (let ((c (read-char stream nil))) 230 (if (and c (not (char= c #\&))) 232 (loop with ent = (make-extendable-string 5) 233 for char = (read-char stream) 234 do (push-string char ent) 235 until (char= char #\;) 236 finally (return (resolve-entity (coerce ent 'simple-string))))))) 238 ;;;--------------------------------------------------------------------------- 239 ;;; Shadow READ-CHAR and UNREAD-CHAR so we can count lines while we parse... 240 ;;;--------------------------------------------------------------------------- 241 (defun read-char (&optional (stream *standard-input*) (eof-error-p t) eof-value recursive-p) 251 (throw 'char-return eof-value))))) 252 (common-lisp:read-char stream t nil recursive-p))))) 253 (when (and (eq stream *parser-stream*) 256 (incf *parser-line-number*)) 259 (defun unread-char (char &optional (stream *standard-input*)) 260 (when (char= char #\newline) 261 (decf *parser-line-number*)) 262 (common-lisp:unread-char char stream)) 264 ;;;END shadowing-------------------------------------------------------------- 266 (define-symbol-macro next-char (peek-stream (state-stream s))) 269 "Consumes one character from the input stream." 270 `(read-char (state-stream s))) 272 (defmacro puke (char) 273 "The opposite of EAT." 274 `(unread-char ,char (state-stream s))) 276 (defmacro match (&rest matchers) 277 "Attempts to match the next input character with one of the supplied matchers." 278 `(let ((c (peek-stream (state-stream s)))) 280 (or ,@(loop for m in matchers 282 (standard-char `(char= ,m c)) 284 ;; cheat here a little bit - eat entire char entity instead 286 (read-stream (state-stream s))))) 288 (defmacro match-seq (&rest sequence) 289 "Tries to match the supplied matchers in sequence with characters in the input stream." 290 `(and ,@(loop for s in sequence 291 collect `(match ,s)))) 293 (defmacro match* (&rest sequence) 294 "Matches any occurances of any of the supplied matchers." 295 `(loop with data = (make-extendable-string 10) 296 for c = (match ,@sequence) 298 do (push-string c data) 299 finally (return data))) 301 (defmacro match+ (&rest sequence) 302 "Matches one or more occurances of any of the supplied matchers." 303 `(and (peek ,@sequence) 304 (match* ,@sequence))) 306 (defmacro peek (&rest matchers) 307 "Looks ahead for an occurance of any of the supplied matchers." 308 `(let ((c (peek-stream (state-stream s)))) 309 (or ,@(loop for m in matchers 311 (standard-char `(char= ,m c)) 312 (symbol `(,m c))))))) 314 (defmacro must (&rest body) 315 "Throws a parse error if the supplied forms do not succeed." 317 (error 'xml-parse-error))) 319 ;;;----------------------------------------------------------------------------- 320 ;;; PARSER INTERNAL FUNCTIONS 321 ;;;----------------------------------------------------------------------------- 323 "Common return type of all rule functions." 324 (type nil :type symbol) 327 (defun resolve-namespace (elem env) 328 "Maps the ns prefix to its associated url via the supplied ns env." 329 (let ((ns (xml-node-ns elem))) 331 (let ((nsurl (assoc ns e :test #'string=))) 333 (setf (xml-node-ns elem) (cadr nsurl)) 336 ;;;----------------------------------------------------------------------------- 337 ;;; MATCH AND RULE BUILDING UTILITIES 338 ;;;----------------------------------------------------------------------------- 339 (defmacro defmatch (name &rest body) 340 "Match definition macro that provides a common lexical environment for matchers." 344 (defmacro defrule (name &rest body) 345 "Rule definition macro that provides a common lexical environment for rules." 349 (defmacro matchfn (name) 350 "Convenience macro for creating an anonymous function wrapper around a matcher macro." 351 `(lambda (s) (match ,name))) 353 (defun none-or-more (s func) 354 "Collects any matches of the supplied rule with the input stream." 355 (declare (type function func)) 356 (let ((val (funcall func s))) 358 (multiple-value-bind (res nextval) 359 (none-or-more s func) 360 (values res (cons val nextval))) 363 (defun one-or-more (s func) 364 "Collects one or more matches of the supplied rule with the input stream." 365 (declare (type function func)) 366 (let ((val (funcall func s))) 368 (multiple-value-bind (res nextval) 369 (none-or-more s func) 370 (declare (ignore res)) 374 ;;;----------------------------------------------------------------------------- 376 ;;;----------------------------------------------------------------------------- 378 (and c (digit-char-p c))) 381 (and c (alpha-char-p c))) 383 ;; Modified because *whitespace* is not defined at compile 384 ;; time. [2004/08/31:rpg] 386 (member c *whitespace*)) 388 ;;; (#.*whitespace* t) 391 (defmatch namechar () 393 (and c (alpha-char-p c)) 394 (and c (digit-char-p c)) 396 ((#\. #\- #\_ #\:) t)))) 398 (defmatch ncname-char () 400 (and c (alpha-char-p c)) 401 (and c (digit-char-p c)) 405 (defmatch attr-text-dq () 406 (and c (not (member c (list #\< #\"))))) 408 (defmatch attr-text-sq () 409 (and c (not (member c (list #\< #\'))))) 411 (defmatch chardata () 412 (and c (not (char= c #\<)))) 414 (defmatch comment-char () 415 (and c (not (eql c #\-)))) 417 ;;;----------------------------------------------------------------------------- 419 ;;;----------------------------------------------------------------------------- 421 (and (peek letter #\_) 422 (match+ ncname-char))) 427 (setf name (ncname s)) 431 (setf suffix (ncname s))) 433 (values name suffix))) 435 (defrule attr-or-nsdecl () 436 (let (suffix name val) 438 (setf (values name suffix) (qname s)) 449 (setf val (match* attr-text-dq)) 455 (setf val (match* attr-text-sq)) 458 (if (string= "xmlns" name) 459 (list 'nsdecl suffix val) 460 ;; If SUFFIX is true, then NAME is Prefix and SUFFIX is 463 (list 'attr suffix val :attr-ns name) 464 (list 'attr name val)))))) 467 (and (match+ ws-char) 468 (make-element :type 'whitespace :val nil))) 472 (peek namechar #\_ #\:) 475 (defrule ws-attr-or-nsdecl () 480 (defrule start-tag () 481 (let (name suffix attrs nsdecls) 484 (setf (values name suffix) (qname s)) 485 (multiple-value-bind (res a) 486 (none-or-more s #'ws-attr-or-nsdecl) 487 (mapcar (lambda (x) (if (eq (car x) 'attr) 489 (push (cdr x) nsdecls))) 495 :name (or suffix name) 496 :ns (and suffix name) 504 (setf (values name suffix) (qname s)) 507 (make-element :type 'end-tag :val (or suffix name))))) 511 (match-seq #\! #\- #\-) 513 (loop until (match-seq #\- #\- #\>) 516 (make-element :type 'comment))) 518 ;;; For the CDATA matching of ]]> I by hand generated an NFA, and then 519 ;;; determinized it (also by hand). Then I did a simpler thing of just pushing 520 ;;; ALL the data onto the data string, and truncating it when done. 521 (defrule comment-or-cdata () 524 (must (or (comment s) 526 (match-seq #\[ #\C #\D #\A #\T #\A #\[) 527 (loop with data = (make-extendable-string 50) 530 do (push-string char data) 535 (trace! :cdata "State 0 Match #\], go to state {0,1} = 4.") 538 (trace! :cdata "State 0 Non-], go to (remain in) state 0.")))) 542 (trace! :cdata "State 4 {0, 1}, match ], go to state {0,1,2} = 5") 545 (trace! :cdata "State 4 {0, 1}, Non-], go to state 0.") 550 (trace! :cdata "State 5 {0, 1, 2}, match ], stay in state 5.")) 552 (trace! :cdata "State 5 {0, 1, 2}, match >, finish match and go to state 3.") 555 (trace! :cdata "State 5 {0, 1, 2}, find neither ] nor >; go to state 0.") 559 finally (return (make-element 562 ;; rip the ]]> off the end of the data and return it... 563 (subseq data 0 (- (fill-pointer data) 3)) 564 'simple-string))))))))) 567 (declaim (ftype function element)) ; forward decl for content rule 570 (must (or (comment-or-cdata s) 571 (processing-instruction s) 575 (and (setf content (match+ chardata)) 576 (make-element :type 'data :val (compress-whitespace content))))))) 579 (let (elem children nsdecls end-name) 581 ;; parse front end of tag 582 (multiple-value-bind (e n) 587 ;; resolve namespaces *before* parsing children 588 (if nsdecls (push nsdecls (state-nsstack s)) t) 589 (or (if (or nsdecls (state-nsstack s)) 590 (resolve-namespace elem (state-nsstack s))) 592 ;; parse end-tag and children 597 (loop for c = (content s) 600 (element (case (element-type c) 602 (return (setf end-name (element-val c)))) 603 ;; processing instructions may be discarded 605 (unless *discard-processing-instructions* 606 (when (element-val c) 607 (push (element-val c) children)))) 608 (t (if (element-val c) 609 (push (element-val c) children))))))) 610 (string= (xml-node-name elem) end-name))) 611 ;; package up new node 613 (setf (xml-node-children elem) (nreverse children)) 614 (make-element :type 'elem :val elem))))) 616 (defrule processing-instruction () 621 (not (string= name "xml")) 622 ;; contents of a processing instruction can be arbitrary stuff, as long 623 ;; as it doesn't contain ?>... 624 (setf contents (pi-contents s)) 625 ;; if we get here, we have eaten ?> off the input in the course of 626 ;; processing PI-CONTENTS 627 (make-element :type 'pi :val (make-proc-inst :target name :contents contents))))) 629 (defrule pi-contents () 630 (loop with data = (make-extendable-string 50) 633 do (push-string char data) 638 (trace! :pi-contents "State 0 Match #\?, go to state 1.") 641 (trace! :pi-contents "State 0 ~c, go to (remain in) state 0." char)))) 645 (trace! :pi-contents "State 1 Match #\>, done.") 648 (trace! :pi-contents "State 1, ~c, do not match #\>, return to 0." char) 651 finally (return (coerce 652 ;; rip the ?> off the end of the data and return it... 653 (subseq data 0 (max 0 (- (fill-pointer data) 2))) 662 (setf contents (none-or-more s #'ws-attr-or-nsdecl)) 664 (make-element :type 'xmldecl :val contents)))) 666 (defrule comment-or-doctype () 667 ;; skip dtd - bail out to comment if it's a comment 668 ;; only match doctype once 672 (and (not (state-got-doctype s)) 673 (must (match-seq #\D #\O #\C #\T #\Y #\P #\E)) 680 (setf (state-got-doctype s) t) 681 (make-element :type 'doctype))))) 686 (and (match #\<) (must (or (processing-instruction s) 687 (comment-or-doctype s) 693 (must (or (xmldecl s) 694 (comment-or-doctype s) 695 (setf elem (element s))))) 696 ;; NOTE: I don't understand this: it seems to parse arbitrary crap 698 (loop for c = (misc s) 700 do (cond ((eql (element-type c) 'elem) 701 (return (setf elem c))) 702 ((and (eql (element-type c) 'pi) 703 (not *discard-processing-instructions*)) 704 (return (setf elem c)))))) 706 (and elem (element-val elem)))) 708 ;;;----------------------------------------------------------------------------- 710 ;;;----------------------------------------------------------------------------- 711 (defun write-xml (e s &key (indent nil)) 712 "Renders a lisp node tree to an xml stream. Indents if indent is non-nil." 714 (toxml e :indent indent) 715 (generate-xml e s (if indent 1 0)))) 717 (defun write-prologue (xml-decl doctype s) 718 "Render the leading <?xml ... ?> and <!DOCTYPE ... > tags to an xml stream." 720 (dolist (attrib xml-decl) 721 (format s " ~A=\"~A\"" (car attrib) (cdr attrib))) 724 (format s "<!DOCTYPE ~A>~%" doctype))) 726 (defun write-prolog (xml-decl doctype s) 727 (write-prologue xml-decl doctype s)) 729 (defun toxml (e &key (indent nil)) 730 "Renders a lisp node tree to an xml string." 731 (with-output-to-string (s) 732 (write-xml e s :indent indent))) 734 (defun xml-parse (s &key (compress-whitespace t) (quash-errors t)) 735 "Parses the supplied stream or string into a lisp node tree." 736 (let* ((*compress-whitespace* compress-whitespace) 737 (*discard-processing-instructions* t) 740 (string (make-string-input-stream s)) 742 (*parser-stream* stream) 743 (*parser-line-number* 1)) 746 (document (make-state :stream stream)) 748 (xml-parse-error () nil)) 749 (document (make-state :stream stream))))) 752 (defun make-xmlrep (tag &key (representation-kind :node) namespace attribs children) 753 (case representation-kind 757 (list (list tag namespace) (list attribs) children)) 759 (list tag (list attribs) children)))) 761 (make-xml-node :name tag :ns namespace :attrs attribs :children children)) 763 (error "REPRESENTATION-KIND must be :LIST or :NODE, found ~s" representation-kind)))) 765 (defgeneric xmlrep-add-child! (xmlrep child) 766 (:method ((xmlrep xml-node) child) 767 (setf (xml-node-children xmlrep) 768 (append (xml-node-children xmlrep) 770 (:method ((xmlrep cons) child) 772 (append (cddr xmlrep) 775 (defgeneric xmlrep-tag (treenode) 776 (:method ((treenode xml-node)) 777 (xml-node-name treenode)) 778 (:method ((treenode cons)) 779 (let ((tag-name (car treenode))) 780 ;; detect the "namespaced" case 782 ((consp tag-name) (car tag-name)) 785 (defun xmlrep-tagmatch (tag treenode) 786 ;;child nodes to XMLREPs could be strings or nodes 787 (unless (stringp treenode) 788 (string-equal tag (xmlrep-tag treenode)))) 790 (defgeneric xmlrep-attribs (treenode) 791 (:method ((treenode xml-node)) 792 (xml-node-attrs treenode)) 793 (:method ((treenode cons)) 796 (defgeneric (setf xmlrep-attribs) (attribs treenode) 797 (:argument-precedence-order treenode attribs) 798 (:method (attribs (treenode xml-node)) 799 (setf (xml-node-attrs treenode) attribs)) 800 (:method (attribs (treenode cons)) 801 (setf (cadr treenode) attribs))) 803 (defgeneric xmlrep-children (treenode) 804 (:method ((treenode xml-node)) 805 (xml-node-children treenode)) 806 (:method ((treenode cons)) 809 (defgeneric (setf xmlrep-children) (children treenode) 810 (:argument-precedence-order treenode children) 811 (:method (children (treenode xml-node)) 812 (setf (xml-node-children treenode) children)) 813 (:method (children (treenode cons)) 814 (setf (cddr treenode) children))) 816 (defun xmlrep-string-child (treenode &optional (if-unfound :error)) 817 (let ((children (xmlrep-children treenode))) 818 (if (and (eq (length children) 1) (typep (first children) 'string)) 820 (if (eq if-unfound :error) 821 (error "Node does not have a single string child: ~a" treenode) 825 (defun xmlrep-integer-child (treenode) 826 (parse-integer (xmlrep-string-child treenode))) 828 (defun xmlrep-find-child-tags (tag treenode) 829 "Find all the children of TREENODE with TAG." 830 (remove-if-not #'(lambda (child) (xmlrep-tagmatch tag child)) 831 (xmlrep-children treenode))) 833 (defun xmlrep-find-child-tag (tag treenode 834 &optional (if-unfound :error)) 835 "Find a single child of TREENODE with TAG. Returns an error 836 if there is more or less than one such child." 837 (let ((matches (xmlrep-find-child-tags tag treenode))) 838 (case (length matches) 839 (0 (if (eq if-unfound :error) 840 (error "Couldn't find child tag ~A in ~A" 844 (otherwise (error "Child tag ~A multiply defined in ~A" 847 (defun xmlrep-attrib-value (attrib treenode 848 &optional (if-undefined :error)) 849 "Find the value of ATTRIB, a string, in TREENODE. 850 if there is no ATTRIB, will return the value of IF-UNDEFINED, 851 which defaults to :ERROR." 852 (let ((found-attrib (find-attrib attrib treenode))) 854 (second found-attrib)) 855 ((eq if-undefined :error) 856 (error "XML attribute ~S undefined in ~S" 861 (defun find-attrib (attrib treenode) 862 "Returns the attrib CELL (not the attrib value) from 863 TREENODE, if found. This cell will be a list of length 2, 864 the attrib name (a string) and its value." 865 (find attrib (xmlrep-attribs treenode) 869 (defun (setf xmlrep-attrib-value) (value attrib treenode) 870 ;; ideally, we would check this... 871 (let ((old-val (xmlrep-attrib-value attrib treenode nil))) 874 ;; just delete this attribute... 875 (setf (xmlrep-attribs treenode) 876 (remove attrib (xmlrep-attribs treenode) 880 (t (let ((cell (find-attrib attrib treenode))) 881 (setf (second cell) value) 885 nil) ; no old value to delete 887 (setf (xmlrep-attribs treenode) 888 (append (xmlrep-attribs treenode) 889 (list (list attrib value)))) 892 (defun xmlrep-boolean-attrib-value (attrib treenode 893 &optional (if-undefined :error)) 894 "Find the value of ATTRIB, a string, in TREENODE. 895 The value should be either \"true\" or \"false\". The 896 function will return T or NIL, accordingly. If there is no ATTRIB, 897 will return the value of IF-UNDEFINED, which defaults to :ERROR." 898 (let ((val (xmlrep-attrib-value attrib treenode 900 (cond ((string-equal val "true") 902 ((string-equal val "false") nil) 903 (t (error "Not a boolean value, ~A for attribute ~A." 906 ;;; XML extraction tool 907 (defun extract-path (key-list xml) 908 "Extracts data from XML parse tree. KEY-LIST is a path for descending down 909 named objects in the XML parse tree. For each KEY-LIST element, XML subforms 910 are searched for a matching tag name. Finally the whole last XML subform on the 911 path is normally returned if found; however the symbol * may be added at the end 912 of KEY-LIST to return list of all objects /enclosed/ by the last subform on 913 KEY-LIST. Also KEY-LIST may be dotted as explained below to return XML tag 914 attributes from the last subform on KEY-LIST. 916 XML is to have the forms as returned by PARSE-TO-LIST or PARSE: 917 (tag-name (attributes-list) subform*), 918 ((tag-name . name-space) (attributes-list) subform*), or 919 #s(node :name tag-name 921 :attrs attributes-list 924 The first element in KEY-LIST must match the top level form in XML. 925 Subsequently each element in the KEY-LIST is to match a subform. 927 An element of KEY-LIST may be a string atom. In that case the first subform 928 with tag-name matching the string is matched. An element of KEY-LIST may also 929 be a list of string atoms in this format: 930 (tag-name (attribute-name attribute-value) ...) 932 The first subform with name matching TAG-NAME /and/ having attributes matching 933 attribute-names and attribute-values is matched. Zero or more attribute/value 936 Normally the whole subform matching last element in KEY-LIST is returned. The 937 symbol * can be the last element of KEY-LIST to return list of all subforms 938 enclosed by the last matched form. Attributes of last matched subform may be 939 searched by ending KEY-LIST in dot notation, in which case the string after dot 940 matches an attribute name. The two element list of attribute name and value is 941 returned. The symbol * may be used after dot to return the whole attribute list. 943 In the case where the search fails NIL is returned. However it is possible that 944 the search partially succeeds down the key path. Three values are returned 945 altogether and the 2nd and 3rd values give information about how much of 946 KEY-LIST was matched, and at what point in XML: 947 (values RESULT KEY-LIST-FRAGMENT XML-FRAGMENT) 949 When RESULT is non-NIL, the others are NIL. When result is NIL however, the 952 The last XML form that /did/ match in the key list. It matches the first 953 element of KEY-LIST-FRAGMENT. 956 The /remaining/ part of the KEY-LIST that did not succeed. However the 957 /first/ item on KEY-LIST-FRAGMENT matches the XML-FRAGMENT returned. The 958 failure is at the second item on KEY-LIST-FRAGMENT. 960 In the case of complete failure, where even the very first item on KEY-LIST does not 961 match the top XML form given, all three return values are NIL. (It suffices to check 962 the first two return values.)" 963 (labels ((attribs-match-p ( key-attribs-list xml-attribs-list ) 964 ;; search for (attr-name attr-value) pairs from KEY-ATTRIBS-LIST on 965 ;; XML-ATTRIBS-LIST. true if all key pairs found. 967 :with attribs-match-var := t 968 :for attrib-key-pair :in key-attribs-list 970 (setq attribs-match-var 971 (and attribs-match-var 972 (find attrib-key-pair xml-attribs-list :test #'equal))) 973 :finally (return attribs-match-var))) 975 (find-test ( key xml-form ) 976 ;; test whether the XML-FORM matches KEY 978 ;; just the XML tag name in key 979 ;; XML name is simple string 981 (stringp (xmlrep-tag xml-form))) 982 (string-equal key (xmlrep-tag xml-form))) 984 ;; key form (tag-name (attr-name attr-value) ...) 985 ((and (find-test (car key) xml-form) 986 (attribs-match-p (cdr key) (xmlrep-attribs xml-form)))))) 988 (descend ( key-list xml-form ) 989 ;; recursive run down KEY-LIST. If XML-FORM runs down to NIL before reaching 990 ;; the end of KEY-LIST, it will be NIL at the end. If not, what is 991 ;; remaining of XML-FORM is the found item. 993 ;; KEY-LIST ends without dotted item, at the target XML form 994 ((null (cdr key-list)) 995 (values xml-form nil nil)) 997 ;; dotted item at the end of KEY-LIST, search attribute list of target XML form 998 ((atom (cdr key-list)) 999 (if (eq '* (cdr key-list)) 1000 (values (xmlrep-attribs xml-form) nil nil) 1001 (find (cdr key-list) (xmlrep-attribs xml-form) 1002 :test (lambda (key item) (equal key (car item)))))) 1004 ;; more tag names to match on KEY-LIST 1006 (if (eq '* (cadr key-list)) 1007 (values (xmlrep-children xml-form) nil nil) 1008 (let ((selected-xml-form (find (cadr key-list) (xmlrep-children xml-form) 1009 :test #'find-test))) 1010 (if selected-xml-form 1011 (descend (cdr key-list) selected-xml-form) 1013 ;; no matching sub-form, indicate what part of KEY-LIST did not match 1014 (values nil key-list xml-form)))))))) 1016 ;; empty list, degenerate usage 1017 (when (null key-list) 1018 (error "KEY-LIST is empty.")) 1020 ;; search down after initial match 1021 (if (find-test (car key-list) xml) 1022 (descend key-list xml) 1023 (values nil nil nil))))