Removing reliance on SXML and adding little xpath evaluator for xexprs

svn: r18366

collects/tests/web-server/dispatchers/dispatch-lang-test.ss

@@ -1,6 +1,5 @@
 #lang scheme/base
 (require schemeunit
-         (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
          mzlib/etc
          mzlib/list
          web-server/dispatchers/dispatch
@@ -53,11 +52,11 @@
       (let* ([xs #"10"]
              [ys #"17"]
              [d (mkd (build-path example-servlets "add-param.ss"))]
-             [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
+             [k0 (simple-xpath* '(form #:action) (call d url0 empty))]
-             [k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?number=~a" k0 xs)
+             [k1 (simple-xpath* '(form #:action) (call d (format "~a?number=~a" k0 xs)
-                                                                (list (make-binding:form #"number" xs)))))]
+                                                       (list (make-binding:form #"number" xs))))]
-             [n (first ((sxpath "//p/text()") (call d (format "~a?number=~a" k1 ys)
+             [n (simple-xpath* '(p) (call d (format "~a?number=~a" k1 ys)
-                                                    (list (make-binding:form #"number" ys)))))])
+                                                    (list (make-binding:form #"number" ys))))])
         n)))
    
    (test-add-two-numbers
@@ -77,11 +76,11 @@
      (test-equal? 
       "add01.ss - no s/s, uri"
       (let* ([d (mkd (build-path example-servlets "add01.ss"))]
-             [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))]
+             [k0 (simple-xpath* '(form #:action) (call d url0 empty))]
-             [k1 (first ((sxpath "//form/@action/text()") (call d (format "~a?first=~a" url0 xs) (list (make-binding:form #"first" xs)))))]
+             [k1 (simple-xpath* '(form #:action) (call d (format "~a?first=~a" url0 xs) (list (make-binding:form #"first" xs))))]
-             [n (first ((sxpath "//p/text()") (call d (format "~a?first=~a&second=~a" url0 xs ys)
+             [n (simple-xpath* '(p) (call d (format "~a?first=~a&second=~a" url0 xs ys)
                                                     (list (make-binding:form #"first" xs)
-                                                          (make-binding:form #"second" ys)))))])
+                                                          (make-binding:form #"second" ys))))])
         n)
       (format "The answer is: ~a" (+ x y))))
    
@@ -134,7 +133,7 @@
    
    (test-equal? "check-dir.ss"
                 (let* ([d (mkd (build-path example-servlets "check-dir.ss"))]
-                       [t0 (first ((sxpath "//h2/text()") (call d url0 empty)))])
+                       [t0 (simple-xpath* '(h2) (call d url0 empty))])
                   t0)
                 (format "The current directory: ~a" (path->string example-servlets)))
    

collects/tests/web-server/dispatchers/dispatch-servlets-test.ss

@@ -1,6 +1,5 @@
 #lang scheme/base
 (require schemeunit
-         (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))
          mzlib/etc
          mzlib/list
          web-server/http
@@ -44,14 +43,14 @@
    (test-pred "configure.ss"
               string?
               (let* ([d (mkd (build-path example-servlets 'up "configure.ss"))]
-                     [k0 (first ((sxpath "//form/@action/text()") (call d url0 empty)))])
+                     [k0 (simple-xpath* '(form #:action) (call d url0 empty))])
                 k0))
    
    (test-suite
     "Examples"
     (test-equal? "hello.ss - loading"
                  (let* ([d (mkd (build-path example-servlets "hello.ss"))]
-                        [t0 (first ((sxpath "//p/text()") (call d url0 empty)))])
+                        [t0 (simple-xpath* '(p) (call d url0 empty))])
                    t0)
                  "Hello, Web!")
     (test-add-two-numbers mkd "add.ss - send/suspend"
@@ -66,30 +65,30 @@
                  (let* ([d (mkd (build-path example-servlets "count.ss"))]
                         [ext (lambda (c)
                                (rest (regexp-match #rx"This servlet was called (.+) times and (.+) times since loaded on" c)))]
-                        [c1 (ext (first ((sxpath "//p/text()") (call d url0 empty))))]
+                        [c1 (ext (simple-xpath* '(p) (call d url0 empty)))]
-                        [c2 (ext (first ((sxpath "//p/text()") (call d url0 empty))))])
+                        [c2 (ext (simple-xpath* '(p) (call d url0 empty)))])
                    (list c1 c2))
                  (list (list "1" "1")
                        (list "2" "1")))
     (test-equal? "dir.ss - current-directory"
                  (let* ([d (mkd (build-path example-servlets "dir.ss"))]
-                        [t0 (first ((sxpath "//p/em/text()") (call d url0 empty)))])
+                        [t0 (simple-xpath* '(p em) (call d url0 empty))])
                    t0)
                  (path->string example-servlets))
     (test-pred "quiz.ss - send/suspend"
                string?
                (let* ([d (mkd (build-path example-servlets "quiz.ss"))])
                  (foldl (lambda (_ k)
-                          (first ((sxpath "//form/@action/text()") (call d k (list (make-binding:form #"answer" #"0"))))))
+                          (simple-xpath* '(form #:action) (call d k (list (make-binding:form #"answer" #"0")))))
                         url0
                         (build-list 7 (lambda (i) i)))))
     (test-equal? "clear.ss - current-servlet-continuation-expiration-handler, clear-continuation-table!, send/finish, send/forward"
                  (let* ([d (mkd (build-path example-servlets "clear.ss"))]
-                        [k0 (first ((sxpath "//a/@href/text()") (call d url0 empty)))]
+                        [k0 (simple-xpath* '(a #:href) (call d url0 empty))]
-                        [k1 (first ((sxpath "//a/@href/text()") (call d k0 empty)))]
+                        [k1 (simple-xpath* '(a #:href) (call d k0 empty))]
-                        [k0-expired (first ((sxpath "//body/text()") (call d k0 empty)))]
+                        [k0-expired (simple-xpath* '(body) (call d k0 empty))]
-                        [done (first ((sxpath "//body/text()") (call d k1 empty)))]
+                        [done (simple-xpath* '(body) (call d k1 empty))]
-                        [k1-expired (first ((sxpath "//body/text()") (call d k1 empty)))])
+                        [k1-expired (simple-xpath* '(body) (call d k1 empty))])
                    (list k0-expired
                          done
                          k1-expired))

collects/tests/web-server/dispatchers/servlet-test-util.ss

@@ -1,6 +1,5 @@
 #lang scheme/base
-(require schemeunit
+(require schemeunit      
-         (planet "sxml.ss" ("lizorkin" "sxml.plt" 2 0))         
          mzlib/list
          web-server/http
          "../util.ss")
@@ -21,15 +20,15 @@
      t
      (let* ([d (mkd p)]
             [r0 (call d url0 empty)]
-            [k0 (first ((sxpath "//form/@action/text()") r0))]
+            [k0 (simple-xpath* '(form #:action) r0)]
-            [i0 (first ((sxpath "//form/input/@name/text()") r0))]
+            [i0 (simple-xpath* '(form input #:name) r0)]
             [r1 (call d (format "~a?~a=~a" k0 i0 xs)
                       (list (make-binding:form (string->bytes/utf-8 i0) xs)))]
-            [k1 (first ((sxpath "//form/@action/text()") r1))]
+            [k1 (simple-xpath* '(form #:action) r1)]
-            [i1 (first ((sxpath "//form/input/@name/text()") r1))]
+            [i1 (simple-xpath* '(form input #:name) r1)]
             [r2 (call d (format "~a?~a=~a" k1 i1 ys)
                       (list (make-binding:form (string->bytes/utf-8 i1) ys)))]
-            [n (first ((sxpath "//p/text()") r2))])
+            [n (simple-xpath* '(p) r2)])
        n)
      (format "The answer is ~a" (+ x y)))))
 
@@ -37,8 +36,8 @@
   (define d (mkd p))
   (define (invoke u)
     (define sx (call d u empty))
-    (define ks ((sxpath "//div/div/a/@href/text()") sx))
+    (define ks (simple-xpath*/list '(div div a #:href) sx))
-    (values ((sxpath "//div/div/h3/text()") sx)
+    (values (simple-xpath*/list '(div div h3) sx)
             (first ks)
             (second ks)))
   (test-equal? t

collects/tests/web-server/servlet-env-test.ss

@@ -1,8 +1,5 @@
 #lang scheme/base
 (require schemeunit
-         #;(only (planet "ssax.ss" ("lizorkin" "ssax.plt" 1 3))
-                 ssax:xml->sxml)
-         #;(planet "sxml.ss" ("lizorkin" "sxml.plt" 1 4))
          mzlib/etc
          mzlib/list
          mzlib/pretty

collects/tests/web-server/util.ss

@@ -1,13 +1,13 @@
 #lang scheme
 (require (for-syntax scheme/base)
          web-server/private/connection-manager
-         (only-in (planet "ssax.ss" ("lizorkin" "ssax.plt" 2 0))
-                  ssax:xml->sxml)
          web-server/http
          web-server/private/web-server-structs
          net/url
          mzlib/pretty
          mzlib/list
+         xml
+         tests/eli-tester
          web-server/private/timer)
 (provide make-module-eval
          make-eval/mod-path
@@ -17,14 +17,76 @@
          htxml
          call)
 
+(define keyword->symbol (compose string->symbol keyword->string))
+(define (simple-xpath/xexpr p x)
+  (match p
+    [(list)
+     (list x)]
+    [(list-rest (? symbol? s) r)
+     (match x
+       [(list-rest (? (curry equal? s)) rs)
+        (simple-xpath/tag-body r rs)]
+       [_
+        empty])]
+    [_
+     empty]))
+(define (simple-xpath/tag-body p x)
+  (match p
+    [(list)
+     (match x
+       [(list) empty]
+       [(list-rest (list (list (? symbol?) (? string?)) ...) rs)
+        (simple-xpath/tag-body p rs)]
+       [(? list?)
+        x]
+       [_ 
+        empty])]
+    [(list-rest (? symbol?) _)
+     (match x
+       [(list-rest (list (list (? symbol?) (? string?)) ...) rs)
+        (simple-xpath/tag-body p rs)]
+       [(? list?)
+        (append-map (curry simple-xpath/xexpr p) x)]
+       [_
+        empty])]
+    [(list (? keyword? k))
+     (match x
+       [(list-rest (and attrs (list (list (? symbol?) (? string?)) ...)) rs)
+        (simple-xpath/attr (keyword->symbol k) attrs)]
+       [_
+        empty])]
+    [_
+     empty]))
+(define (simple-xpath/attr k attrs)
+  (dict-ref attrs k empty))
+(define (simple-xpath*/list p x)
+  (append (simple-xpath/xexpr p x)
+          (match x
+            [(list-rest (list (cons (? symbol?) (? string?)) ...) rs)
+             (simple-xpath*/list p rs)]
+            [(? list?)
+             (append-map (curry simple-xpath*/list p) x)]
+            [_
+             empty])))
+(define (simple-xpath* p x)
+  (match (simple-xpath*/list p x)
+    [(list) #f]
+    [(list-rest f rs) f]))
+
+(test
+ (simple-xpath*/list '(p) '(html (body (p "Hey") (p "Bar")))) => (list "Hey" "Bar")
+ (simple-xpath* '(p) '(html (body (p "Hey")))) => "Hey"
+ (simple-xpath* '(p #:bar) '(html (body (p ([bar "Zog"]) "Hey")))) => "Zog")    
+
+(provide simple-xpath*
+         simple-xpath*/list)
+
 (define (call d u bs)
   (htxml (collect d (make-request #"GET" (string->url u) empty (delay bs) #"" "127.0.0.1" 80 "127.0.0.1"))))
 (define (htxml bs)
   (match (regexp-match #"^.+\r\n\r\n(.+)$" bs)
     [(list _ s)
-     (define sx (ssax:xml->sxml (open-input-bytes s) empty))
+     (string->xexpr (bytes->string/utf-8 s))]
-     #;(pretty-print sx)
-     sx]
     [_
      (error 'html "Given ~S~n" bs)]))