[new exported functions EVALUATE, FIRST-NODE, ALL-NODES
david@lichteblau.com**20071125202312
 
 A new function EVALUATE is provided that...
   - automatically parses XPath strings.
   - also accepts sexps in the syntax (xpath (sexp-goes-here)).  (The special
     marker XPATH in the CAR is needed to distinguish literal strings from XPath
     strings.)
   - and accepts pre-compiled closures.  Users who want to use this function
     with a customized environment must pass precompiled closures.
 
 For the first two cases, the environment is defined lexically using the
 new macro WITH-NAMESPACES. 
 
 The context argument to ALL-NODES can be either...
   - an actual context
   - or any other node understood by the XPath protocol, and will then
     be turned into a trivial context automatically
 
 A compiler macro on EVALUATE allows pre-compilation of closures at fasl
 load time.  (Macrolet tricks propagate the information from WITH-NAMESPACES
 into the compiler macro.  Thanks to chandler on #lisp for the tip.)
] {
hunk ./axes.lisp 58
-	(nreverse (force (subpipe-before node (child-pipe parent))))
+	(nreverse (force (subpipe-before node (xpath-protocol:child-pipe
+					       parent))))
hunk ./lexer.lisp 455
-   :ns-name
+   (:ns-name (lambda* (a) `(:namespace ,a)))
hunk ./node-tests.lisp 7
+      #+nil
+      (format t "node ~s principal-node-type ~s name ~s uri ~s~%"
+	      node principal-node-type
+	      local-name
+	      uri)
hunk ./package.lisp 26
+
+	   #:evaluate
+	   #:xpath
+	   #:first-node
+	   #:all-nodes
+	   #:node-set
hunk ./types.lisp 13
+(defmethod print-object ((object node-set) stream)
+  (print-unreadable-object (object stream :type t :identity t)
+    (if (pipe-of object)
+	(format stream "~A, ~_..." (pipe-head (pipe-of object)))
+	(write-string "empty" stream))))
+
hunk ./types.lisp 124
+
+;; lexical environment
+;;
+;; The environment used automatically by our compiler-macros, and that
+;; knows about namespaces declared locally using WITH-NAMESPACES.
+
+(defstruct (lexical-environment
+	     (:include environment)
+	     (:constructor make-lexical-environment (namespaces)))
+  namespaces)
+
+(defmethod environment-find-namespace
+    ((environment lexical-environment) prefix)
+  (cdr (assoc prefix (lexical-environment-namespaces environment)
+	      :test 'equal)))
+
+;;; (defmethod environment-find-function ((environment lexical-environment) lname uri)
+;;;   )
+
+;;; (defmethod environment-validate-variable
+;;;     ((environment lexical-environment) lname uri)
+;;;   (declare (ignore lname uri))
+;;;   )
+
+(defparameter *initial-namespaces*
+  '((nil . "")
+    ("xmlns" . #"http://www.w3.org/2000/xmlns/")
+    ("xml" . #"http://www.w3.org/XML/1998/namespace")))
+
+(defparameter *lexical-namespaces* nil)
+
+(defmacro lexical-namespaces () nil)
+
+(defmacro with-namespaces ((&rest bindings) &body body &environment env)
+  (let ((conses
+	 (append (loop
+		    for (prefix uri) in bindings
+		    do
+		      (check-type prefix string)
+		      (check-type uri string)
+		    collect (cons prefix uri))
+		 (or (macroexpand '(lexical-namespaces) env)
+		     *initial-namespaces*))))
+    `(let ((*lexical-namespaces* ',conses))
+       (macrolet ((lexical-namespaces () ',conses))
+	 ,@body))))
+
hunk ./xpath-test.lisp 28
+(defparameter *sample-xml-2*
+  (cxml:parse-rod
+   (concat 
+    "<div class='something' xmlns:special='http://special'>"
+    "<special:a href='zzz'>"
+    "<span class='sample'>val1</span>"
+    "val2"
+    "</special:a>"
+    "<a href='qqq' id='a2'>"
+    "<span class='sample'>val3</span>"
+    "<span><br/></span>"
+    "</a>"
+    "<special:span class='another'>another-value</special:span>"
+    "<span class='yetanother' id='s5'>42<hr/></span>"
+    "</div>")
+   (cxml-dom:make-dom-builder)))
+
hunk ./xpath-test.lisp 273
+(deftest test-with-namespaces-1
+  (with-namespaces (("" ""))
+    (eq (first-node (evaluate "/div" *sample-xml*))
+	(dom:document-element *sample-xml*))))
+
+(deftest test-with-namespaces-2
+  (with-namespaces (("foo" "http://special"))
+    (eql 1 (length (all-nodes (evaluate "//foo:a" *sample-xml-2*))))))
+
+(deftest test-with-namespaces-3
+  (with-namespaces (("foo" "http://special"))
+    (eql 2 (length (all-nodes (evaluate "//foo:*" *sample-xml-2*))))))
+
+(with-namespaces (("foo" "http://special"))
+  (deftest test-with-namespaces-4
+    (eql 2 (length (all-nodes (evaluate "//foo:*" *sample-xml-2*))))))
+
+(deftest test-with-namespaces-5
+  (handler-case
+      (funcall (compile nil
+			`(lambda ()
+			   (with-namespaces (("foo" "http://special"))
+			     (evaluate "//bar:*" *sample-xml-2*)))))
+    (error ()
+      t)
+    (:no-error (x)
+      (error "test failed with return value ~A" x))))
+
hunk ./xpath.lisp 109
-      (environment-find-namespace environment prefix)
+      (or (environment-find-namespace environment prefix)
+	  (error "undeclared namespace: ~A" prefix))
hunk ./xpath.lisp 213
+;; public evaluation API
+
+(defun first-node (node-set)
+  (pipe-head (pipe-of node-set)))
+
+(defun all-nodes (node-set)
+  (force (pipe-of node-set)))
+
+(defmacro xpath (form)
+  `(list 'xpath ',form))
+
+(defun evaluate (xpath context)
+  (when (typep xpath 'string)
+    (setf xpath (list 'xpath (parse-xpath xpath))))
+  (when (listp xpath)
+    (unless (and (consp xpath) (eq (car xpath) 'xpath) (null (cddr xpath)))
+      (error "invalid xpath designator: ~A" xpath))
+    (setf xpath (compile-xpath (second xpath)
+			       (make-lexical-environment
+				*lexical-namespaces*))))
+  (unless (functionp xpath)
+    (error "invalid xpath designator: ~A" xpath))
+  (unless (typep context 'context)
+    ;; FIXME: Should this perhaps compute position and size based on 
+    ;; the node's siblings instead?
+    (setf context (make-context context)))
+  (funcall xpath context))
+
+(define-compiler-macro evaluate (&whole whole &environment env xpath context)
+  (let ((namespaces (macroexpand '(lexical-namespaces) env)))
+    (unless namespaces
+      (error "EVALUATE used outside of with-namespaces"))
+    (if (or (and (stringp xpath)
+		 (not (functionp xpath)))
+	    (and (consp xpath) (eq (car xpath) 'xpath)))
+	(let ((y (if (typep xpath 'string)
+		     (list 'xpath (parse-xpath xpath))
+		     xpath)))
+	  (unless (and (consp y)
+		       (eq (car y) 'xpath)
+		       (null (cddr y)))
+	    (error "invalid xpath designator: ~A" y))
+	  `(evaluate (load-time-value
+		      (compile-xpath ',(second y)
+				     (make-lexical-environment ',namespaces)))
+		     ,context))
+	whole)))
+
}