test/domtest.lisp

   1 (defpackage :domtest
   2   (:use :cl :cxml)
   3   (:export #:run-all-tests))
   4 (defpackage :domtest-tests
   5   (:use))
   6 (in-package :domtest)
   7
   8
   9 ;;;; allgemeine Hilfsfunktionen
  10
  11 (defmacro string-case (keyform &rest clauses)
  12   (let ((key (gensym "key")))
  13     `(let ((,key ,keyform))
  14        (declare (ignorable ,key))
  15        (cond
  16          ,@(loop
  17                for (keys . forms) in clauses
  18                for test = (etypecase keys
  19                             (string `(string= ,key ,keys))
  20                             (sequence `(find ,key ',keys :test 'string=))
  21                             ((eql t) t))
  22                collect
  23                  `(,test ,@forms))))))
  24
  25 (defun rcurry (function &rest args)
  26   (lambda (&rest more-args)
  27     (apply function (append more-args args))))
  28
  29 (defmacro for ((&rest clauses) &rest body-forms)
  30   `(%for ,clauses (progn ,@body-forms)))
  31
  32 (defmacro for* ((&rest clauses) &rest body-forms)
  33   `(%for* ,clauses (progn ,@body-forms)))
  34
  35 (defmacro %for ((&rest clauses) body-form &rest finally-forms)
  36   (for-aux 'for clauses body-form finally-forms))
  37
  38 (defmacro %for* ((&rest clauses) body-form &rest finally-forms)
  39   (for-aux 'for* clauses body-form finally-forms))
  40
  41 (defmacro for-finish ()
  42   '(loop-finish))
  43
  44 (eval-when (:compile-toplevel :load-toplevel :execute)
  45   (defun for-aux (kind clauses body-form finally-forms)
  46     ` (loop ,@ (loop for firstp = t then nil
  47                    for %clauses = clauses then (rest %clauses)
  48                    for clause = (first %clauses) then (first %clauses)
  49                    while (and %clauses (listp clause))
  50                    append (cons (ecase kind
  51                                   (for (if firstp 'as 'and))
  52                                   (for* 'as))
  53                                 (if (= 2 (length clause))
  54                                     (list (first clause) '= (second clause))
  55                                     clause))
  56                    into result
  57                    finally (return (append result %clauses)))
  58           do (progn ,body-form)
  59           finally (progn ,@finally-forms))))
  60
  61
  62 ;;;; spezielle Hilfsfunktionen
  63
  64 (defun tag-name (elt)
  65   (runes:rod-string (dom:tag-name elt)))
  66
  67 (defmacro with-attributes ((&rest attributes) element &body body)
  68   (let ((e (gensym "element")))
  69     `(let* ((,e ,element)
  70             ,@(mapcar (lambda (var)
  71                        `(,var (dom:get-attribute ,e ,(symbol-name var))))
  72                      attributes))
  73        ,@body)))
  74
  75 (defun map-child-elements (result-type fn element &key name)
  76   (remove '#1=#:void
  77           (map result-type
  78             (lambda (node)
  79               (if (and (eq (dom:node-type node) :element)
  80                        (or (null name)
  81                            (equal (tag-name node) name)))
  82                   (funcall fn node)
  83                   '#1#))
  84             (dom:child-nodes element))))
  85
  86 (defmacro do-child-elements ((var element &key name) &body body)
  87   `(block nil
  88      (map-child-elements nil (lambda (,var) ,@body) ,element :name ,name)))
  89
  90 (defun find-child-element (name element)
  91   (do-child-elements (child element :name name)
  92     (return child)))
  93
  94 (defun %intern (name)
  95   (unless (stringp name)
  96     (setf name (runes:rod-string name)))
  97   (if (zerop (length name))
  98       nil
  99       (intern name :domtest-tests)))
 100
 101 (defun replace-studly-caps (str)
 102   (unless (stringp str)
 103     (setf str (runes:rod-string str)))
 104   ;; s/([A-Z][a-z])/-\1/
 105   (with-output-to-string (out)
 106     (with-input-from-string (in str)
 107       (for ((c = (read-char in nil nil))
 108             (previous = nil then c)
 109             (next = (peek-char nil in nil nil))
 110             :while c)
 111         (when (and previous
 112                    (upper-case-p c) next (lower-case-p next)
 113                    (not (lower-case-p previous)))
 114           (write-char #\- out))
 115         (write-char (char-downcase c) out)
 116         (when (and (lower-case-p c) next (upper-case-p next))
 117           (write-char #\- out))))))
 118
 119 (defun intern-dom (name)
 120   (setf name (replace-studly-caps name))
 121   (when (eq :foo :FOO)
 122     (setf name (string-upcase name)))
 123   (intern name :dom))
 124
 125 (defun child-elements (element)
 126   (map-child-elements 'list #'identity element))
 127
 128 (defun parse-java-literal (str)
 129   (when (stringp str)
 130     (setf str (runes:string-rod str)))
 131   (cond
 132     ((zerop (length str)) nil)
 133     ((runes:rod= str #"true")
 134       t)
 135     ((runes:rod= str #"false")
 136       nil)
 137     ((digit-char-p (runes:rune-char (elt str 0)))
 138       (parse-integer (runes:rod-string str)))
 139     ((runes:rune= (elt str 0) #.(runes:char-rune #\"))
 140       (let ((v (make-array 1 :fill-pointer 0 :adjustable t)))
 141         (for* ((i = 1 :then (1+ i))
 142                (c = (elt str i))
 143                :until (runes:rune= c #.(runes:char-rune #\")))
 144             (if (runes:rune= c #.(runes:char-rune #\\))
 145                 (let ((frob
 146                        (progn
 147                          (incf i)
 148                          (elt str i))))
 149                   (ecase frob
 150                     ;; ...
 151                     (#/n (vector-push-extend #/newline v (length v)))
 152                     ((#/\\ #/\") (vector-push-extend #/\\ v (length v)))))
 153                 (vector-push-extend c v (length v))))
 154         (make-array (length v) :element-type 'runes:rune :initial-contents v)))
 155     (t
 156       (%intern str))))
 157
 158 (defun maybe-setf (place form)
 159   (if place
 160       `(setf ,place ,form)
 161       form))
 162
 163 (defun nullify (str)
 164   (if (zerop (length str)) nil str))
 165
 166
 167 ;;;; dom1-interfaces.xml auslesen
 168
 169 (defparameter *methods* '())
 170 (defparameter *fields* '())
 171
 172 (declaim (special *directory*))
 173 (declaim (special *files-directory*))
 174
 175 (defun read-members (&optional (directory *directory*))
 176   (let* ((pathname (merge-pathnames "build/dom2-interfaces.xml" directory))
 177          (builder (rune-dom:make-dom-builder))
 178          (library (dom:document-element
 179                    (cxml:parse-file pathname builder :recode nil)))
 180          (methods '())
 181          (fields '()))
 182     (do-child-elements (interface library :name "interface")
 183       (do-child-elements (method interface :name "method")
 184         (let ((parameters (find-child-element "parameters" method)))
 185           (push (cons (dom:get-attribute method "name")
 186                       (map-child-elements 'list
 187                                           (rcurry #'dom:get-attribute "name")
 188                                           parameters
 189                                           :name "param"))
 190                 methods)))
 191       (do-child-elements (attribute interface :name "attribute")
 192         (push (dom:get-attribute attribute "name") fields)))
 193     (values methods fields)))
 194
 195
 196 ;;;; Conditions uebersetzen
 197
 198 (defun translate-condition (element)
 199   (string-case (tag-name element)
 200     ("equals" (translate-equals element))
 201     ("notEquals" (translate-not-equals element))
 202     ("contentType" (translate-content-type element))
 203     ("implementationAttribute" (assert-have-implementation-attribute element))
 204     ("isNull" (translate-is-null element))
 205     ("not" (translate-is-null element))
 206     ("notNull" (translate-not-null element))
 207     ("or" (translate-or element))
 208     ("same" (translate-same element))
 209     ("less" (translate-less element))
 210     (t (error "unknown condition: ~A" element))))
 211
 212 (defun equalsp (a b test)
 213   (when (dom:named-node-map-p a)
 214     (setf a (dom:items a)))
 215   (when (dom:named-node-map-p b)
 216     (setf b (dom:items b)))
 217   (if (and (typep a 'sequence) (typep b 'sequence))
 218       (null (set-exclusive-or (coerce a 'list) (coerce b 'list) :test test))
 219       (funcall test a b)))
 220
 221 (defun %equal (a b)
 222   (or (equal a b) (and (runes::rodp a) (runes::rodp b) (runes:rod= a b))))
 223
 224 (defun %equalp (a b)
 225   (or (equalp a b) (and (runes::rodp a) (runes::rodp b) (runes:rod-equal a b))))
 226
 227 (defun translate-equals (element)
 228   (with-attributes (|actual| |expected| |ignoreCase|) element
 229     `(equalsp ,(%intern |actual|)
 230               ,(parse-java-literal |expected|)
 231               ',(if (parse-java-literal |ignoreCase|) '%equal '%equal))))
 232
 233 (defun translate-not-equals (element)
 234   `(not ,(translate-equals element)))
 235
 236 (defun translate-same (element)
 237   (with-attributes (|actual| |expected|) element
 238     `(eql ,(%intern |actual|) ,(parse-java-literal |expected|))))
 239
 240 (defun translate-less (element)
 241   (with-attributes (|actual| |expected|) element
 242     `(< ,(%intern |actual|) ,(parse-java-literal |expected|))))
 243
 244 (defun translate-or (element)
 245   `(or ,@(map-child-elements 'list #'translate-condition element)))
 246
 247 (defun translate-instance-of (element)
 248   (with-attributes (|obj| |type|) element
 249     `(eq (dom:node-type ,(%intern |obj|))
 250          ',(string-case (runes:rod-string |type|)
 251              ("Document" :document)
 252              ("DocumentFragment" :document-fragment)
 253              ("Text" :text)
 254              ("Comment" :comment)
 255              ("CDATASection" :cdata-section)
 256              ("Attr" :attribute)
 257              ("Element" :element)
 258              ("DocumentType" :document-type)
 259              ("Notation" :notation)
 260              ("Entity" :entity)
 261              ("EntityReference" :entity-reference)
 262              ("ProcessingInstruction" :processing-instruction)
 263              (t (error "unknown interface: ~A" |type|))))))
 264
 265 (defun translate-is-null (element)
 266   (with-attributes (|obj|) element
 267     `(null ,(%intern |obj|))))
 268
 269 (defun translate-not-null (element)
 270   (with-attributes (|obj|) element
 271     (%intern |obj|)))
 272
 273 (defun translate-content-type (element) ;XXX verstehe ich nicht
 274   (with-attributes (|type|) element
 275    `(equal ,|type| "text/xml")))
 276
 277 (defun translate-uri-equals (element)
 278   (with-attributes
 279       (|actual|
 280        |scheme| |path| |host| |file| |name| |query| |fragment| |isAbsolute|)
 281       element
 282     |isAbsolute|
 283    `(let ((uri (net.uri:parse-uri (runes:rod-string ,(%intern |actual|)))))
 284       (flet ((uri-directory (path)
 285                (namestring
 286                 (make-pathname :directory (pathname-directory path))))
 287              (uri-file (path)
 288                (namestring (make-pathname :name (pathname-name path)
 289                                           :type (pathname-type path))))
 290              (uri-name (path)
 291                (pathname-name path))
 292              (maybe-equal (expected actual)
 293                (if expected
 294                    (%equal (runes::rod expected) (runes::rod actual))
 295                    t)))
 296         (and (maybe-equal ,(parse-java-literal |scheme|)
 297                           (net.uri:uri-scheme uri))
 298              (maybe-equal ,(parse-java-literal |host|)
 299                           (net.uri:uri-host uri))
 300              (maybe-equal ,(parse-java-literal |path|)
 301                           (uri-directory (net.uri:uri-path uri)))
 302              (maybe-equal ,(parse-java-literal |file|)
 303                           (uri-file (net.uri:uri-path uri)))
 304              (maybe-equal ,(parse-java-literal |name|)
 305                           (uri-name (net.uri:uri-path uri)))
 306              (maybe-equal ,(parse-java-literal |query|)
 307                           (net.uri:uri-query uri))
 308              (maybe-equal ,(parse-java-literal |fragment|)
 309                           (net.uri:uri-fragment uri)))))))
 310
 311
 312 ;;;; Statements uebersetzen
 313
 314 (defun translate-statement (element)
 315   (string-case (tag-name element)
 316     ("append" (translate-append element))
 317     ("assertDOMException" (translate-assert-domexception element))
 318     ("assertEquals"     (translate-assert-equals element))
 319     ("assertNotNull"    (translate-assert-not-null element))
 320     ("assertInstanceOf" (translate-assert-instance-of element))
 321     ("assertNull"       (translate-assert-null element))
 322     ("assertSame"       (translate-assert-same element))
 323     ("assertSize"       (translate-assert-size element))
 324     ("assertTrue"       (translate-assert-true element))
 325     ("assertFalse"      (translate-assert-false element))
 326     ("assertURIEquals"  (translate-assert-uri-equals element))
 327     ("assign"           (translate-assign element))
 328     ("for-each"         (translate-for-each element))
 329     ("fail"             (translate-fail element))
 330     ("hasFeature" (translate-has-feature element))
 331     ("if"               (translate-if element))
 332     ("implementation"   (translate-implementation element))
 333     ("increment"        (translate-unary-assignment '+ element))
 334     ("decrement"        (translate-unary-assignment '- element))
 335     ("length"           (translate-length element))
 336     ("load"             (translate-load element))
 337     ("nodeType"         (translate-node-type element))
 338     ("plus"             (translate-binary-assignment '+ element))
 339     ("try"              (translate-try element))
 340     ("while"            (translate-while element))
 341     (t                  (translate-member element))))
 342
 343 (defun translate-binary-assignment (fn element)
 344   (with-attributes (|var| |op1| |op2|) element
 345     (maybe-setf (%intern |var|)
 346                 `(,fn ,(parse-java-literal |op1|)
 347                       ,(parse-java-literal |op2|)))))
 348
 349 (defun translate-assign (element)
 350   (with-attributes (|var| |value|) element
 351     (maybe-setf (%intern |var|) (parse-java-literal |value|))))
 352
 353 (defun translate-unary-assignment (fn element)
 354   (with-attributes (|var| |value|) element
 355     (maybe-setf (%intern |var|)
 356                 `(,fn ,(%intern |var|) ,(parse-java-literal |value|)))))
 357
 358 (defun translate-load (load)
 359   (with-attributes (|var| |href| |willBeModified|) load
 360     (maybe-setf (%intern |var|)
 361                 `(load-file ,|href| ,(parse-java-literal |willBeModified|)))))
 362
 363 (defun translate-implementation (elt)
 364   (with-attributes (|var|) elt
 365     (maybe-setf (%intern |var|) `'rune-dom:implementation)))
 366
 367 (defun translate-length (load)
 368   ;; XXX Soweit ich sehe unterscheiden die Tests nicht zwischen
 369   ;; der Laenge von DOMString und der length()-Methode der uebrigen
 370   ;; Interfaces.  Also unterscheiden wir das erstmal manuell.
 371   (with-attributes (|var| |obj|) load
 372     (let ((obj (%intern |obj|)))
 373       (maybe-setf (%intern |var|)
 374                   `(if (typep ,obj 'sequence)
 375                        (length ,obj)
 376                        (dom:length ,obj))))))
 377
 378 (defun translate-call (call method)
 379   (let ((name (car method))
 380         (args (mapcar (lambda (name)
 381                         (parse-java-literal (dom:get-attribute call name)))
 382                       (cdr method))))
 383     (with-attributes (|var| |obj|) call
 384       (maybe-setf (%intern |var|)
 385                   `(,(intern-dom name) ,(%intern |obj|) ,@args)))))
 386
 387 (defun translate-get (call name)
 388   (with-attributes (|var| |value| |obj|) call
 389     (cond
 390       ((nullify |var|)                  ;get
 391         (maybe-setf (%intern |var|) `(,(intern-dom name) ,(%intern |obj|))))
 392       ((nullify |value|)                ;set
 393         `(setf (,(intern-dom name) ,(%intern |obj|))
 394                ,(parse-java-literal |value|)))
 395       (t
 396         (error "oops")))))
 397
 398 (defun translate-has-feature (element)
 399   (with-attributes (|obj| |var| |feature| |version|) element
 400     (if (nullify |obj|)
 401         (translate-member element)
 402         (maybe-setf (%intern |var|)
 403                     `(dom:has-feature 'rune-dom:implementation
 404                                       ,(parse-java-literal |feature|)
 405                                       ,(parse-java-literal |version|))))))
 406
 407 (defun translate-fail (element)
 408   (declare (ignore element))
 409   `(error "failed"))
 410
 411 (defun translate-node-type (element)
 412   ;; XXX Das muessten eigentlich ints sein, sind aber Keywords in CXML.
 413   (with-attributes (|var| |obj|) element
 414     (maybe-setf (%intern |var|)
 415                 `(ecase (dom:node-type ,(%intern |obj|))
 416                    (:element                1)
 417                    (:attribute              2)
 418                    (:text                   3)
 419                    (:cdata-section          4)
 420                    (:entity-reference       5)
 421                    (:entity                 6)
 422                    (:processing-instruction 7)
 423                    (:comment                8)
 424                    (:document               9)
 425                    (:document-type          10)
 426                    (:document-fragment      11)
 427                    (:notation               12)))))
 428
 429 (defun translate-member (element)
 430   (let* ((name (dom:tag-name element))
 431          (method (find name *methods* :key #'car :test #'runes:rod=))
 432          (field (find name *fields* :test #'runes:rod=)))
 433     (cond
 434       (method (translate-call element method))
 435       (field (translate-get element field))
 436       (t (error "unknown element ~A" element)))))
 437
 438 (defun translate-assert-equals (element)
 439   `(assert ,(translate-equals element)))
 440
 441 (defun translate-assert-same (element)
 442   `(assert ,(translate-same element)))
 443
 444 (defun translate-assert-null (element)
 445   (with-attributes (|actual|) element
 446     `(assert (null ,(%intern |actual|)))))
 447
 448 (defun translate-assert-not-null (element)
 449   (with-attributes (|actual|) element
 450     `(assert ,(%intern |actual|))))
 451
 452 (defun translate-assert-size (element)
 453   (with-attributes (|collection| |size|) element
 454     `(let ((collection ,(%intern |collection|)))
 455        (when (dom:named-node-map-p collection)
 456          (setf collection (dom:items collection)))
 457        (assert (eql (length collection) ,(parse-java-literal |size|))))))
 458
 459 (defun translate-assert-instance-of (element)
 460   `(assert ,(translate-instance-of element)))
 461
 462 (defun translate-if (element)
 463   (destructuring-bind (condition &rest rest)
 464       (child-elements element)
 465     (let (then else)
 466       (dolist (r rest)
 467         (when (equal (tag-name r) "else")
 468           (setf else (child-elements r))
 469           (return))
 470         (push r then))
 471       `(cond
 472          (,(translate-condition condition)
 473            ,@(mapcar #'translate-statement (reverse then)))
 474          (t
 475            ,@(mapcar #'translate-statement else))))))
 476
 477 (defun translate-while (element)
 478   (destructuring-bind (condition &rest body)
 479       (child-elements element)
 480     `(loop
 481          while ,(translate-condition condition)
 482          do (progn ,@(mapcar #'translate-statement body)))))
 483
 484 (defun translate-assert-domexception (element)
 485   (do-child-elements (c element)
 486     (unless (equal (tag-name c) "metadata")
 487       (return
 488         `(block assert-domexception
 489            (handler-bind
 490                ((rune-dom::dom-exception
 491                  (lambda (c)
 492                    (when (eq (rune-dom::dom-exception-key c)
 493                              ,(intern (tag-name c) :keyword))
 494                      (return-from assert-domexception)))))
 495              ,@(translate-body c)
 496              (error "expected exception ~A" ,(tag-name c))))))))
 497
 498 (defun translate-catch (catch return)
 499   `(lambda (c)
 500      ,@(map-child-elements
 501         'list
 502         (lambda (exception)
 503           `(when (eq (rune-dom::dom-exception-key c)
 504                      ,(intern (runes:rod-string (dom:get-attribute exception "code"))
 505                               :keyword))
 506              ,@(translate-body exception)
 507              ,return))
 508         catch)))
 509
 510 (defun translate-try (element)
 511   `(block try
 512      (handler-bind
 513          ((rune-dom::dom-exception
 514            ,(translate-catch
 515              (do-child-elements (c element :name "catch") (return c))
 516              '(return-from try))))
 517        ,@(map-child-elements 'list
 518                              (lambda (c)
 519                                (if (equal (tag-name c) "catch")
 520                                    nil
 521                                    (translate-statement c)))
 522                              element))))
 523
 524 (defun translate-append (element)
 525   (with-attributes (|collection| |item|) element
 526     (let ((c (%intern |collection|))
 527           (i (%intern |item|)))
 528       (maybe-setf c `(append ,c (list ,i))))))
 529
 530 (defun translate-assert-true (element)
 531   (with-attributes (|actual|) element
 532     `(assert ,(if (nullify |actual|)
 533                   (%intern |actual|)
 534                   (translate-condition
 535                    (do-child-elements (c element) (return c)))))))
 536
 537 (defun translate-assert-false (element)
 538   (with-attributes (|actual|) element
 539     `(assert (not ,(%intern |actual|)))))
 540
 541 (defun translate-assert-uri-equals (element)
 542   `(assert ,(translate-uri-equals element)))
 543
 544
 545 ;;;; Tests uebersetzen
 546
 547 (defun translate-body (element)
 548   (map-child-elements 'list #'translate-statement element))
 549
 550 (defun translate-for-each (element)
 551   (with-attributes (|collection| |member|) element
 552     `(let ((collection ,(%intern |collection|)))
 553        (when (dom:named-node-map-p collection)
 554          (setf collection (dom:items collection)))
 555        (map nil (lambda (,(%intern |member|)) ,@(translate-body element))
 556             collection))))
 557
 558 (defun assert-have-implementation-attribute (element)
 559   (let ((attribute (runes:rod-string (dom:get-attribute element "name"))))
 560     (string-case attribute
 561       ;; fixme: expandEntityReferences sollten wir auch mal anschalten, wo
 562       ;; wir uns schon die muehe machen...
 563       ("validating"
 564         (setf cxml::*validate* t))
 565       ("namespaceAware"
 566         ;; ???  dom 2 ohne namespace-support gibt's doch gar nicht,
 567         ;; ausser vielleicht in html-only implementationen, und dann sollen
 568         ;; sie halt auf hasFeature "XML" testen.
 569         )
 570       (t
 571         (format t "~&implementationAttribute ~A not supported, skipping test~%"
 572                 attribute)
 573         (throw 'give-up nil)))))
 574
 575 (defun slurp-test (pathname)
 576   (unless *fields*
 577     (multiple-value-setq (*methods* *fields*) (read-members)))
 578   (catch 'give-up
 579     (let* ((builder (rune-dom:make-dom-builder))
 580            (cxml::*validate* nil)         ;dom1.dtd is buggy
 581            (test (dom:document-element
 582                   (cxml:parse-file pathname builder :recode nil)))
 583            title
 584            (bindings '())
 585            (code '()))
 586       (declare (ignorable title))
 587       (do-child-elements (e test)
 588         (string-case (tag-name e)
 589           ("metadata"
 590             (let ((title-element (find-child-element "title" e)))
 591               (setf title (dom:data (dom:first-child title-element)))))
 592           ("var"
 593             (push (list (%intern (dom:get-attribute e "name"))
 594                         (string-case (runes:rod-string
 595                                        (dom:get-attribute e "type"))
 596                           (("byte" "short" "int" "long") 0)
 597                           (t nil)))
 598                   bindings)
 599             (let ((value (dom:get-attribute e "value")))
 600               (when value
 601                 (push `(setf ,(%intern (dom:get-attribute e "name"))
 602                              ,(parse-java-literal value))
 603                       code)))
 604             (do-child-elements (member e :name "member") e
 605               (push `(setf ,(%intern (dom:get-attribute e "name"))
 606                            (append ,(%intern (dom:get-attribute e "name"))
 607                                    (list
 608                                     ,(parse-java-literal
 609                                       (dom:data
 610                                        (dom:item
 611                                         (dom:child-nodes member)
 612                                         0))))))
 613                     code)))
 614           ("implementationAttribute"
 615             (assert-have-implementation-attribute e))
 616           (t
 617             (push (translate-statement e) code))))
 618       `(lambda ()
 619          (let ((*files-directory* ,*files-directory*) ;fuer copy&paste:
 620                ,@bindings)
 621            (declare (ignorable ,@(mapcar #'car bindings)))
 622            ,@(reverse code))))))
 623
 624 (defun load-file (name &optional will-be-modified-p)
 625   (declare (ignore will-be-modified-p))
 626   (setf name (runes:rod-string name))
 627   (cxml:parse-file
 628    (make-pathname :name name :type "xml" :defaults *files-directory*)
 629    (rune-dom:make-dom-builder)
 630    :recode nil))
 631
 632 (defparameter *bad-tests*
 633     '("hc_elementnormalize2.xml"
 634       "hc_nodereplacechildnewchildexists.xml"
 635       "characterdatadeletedatanomodificationallowederr.xml"))
 636
 637 (defun dribble-tests (directory)
 638   (let ((base (slot-value (asdf:find-system :cxml) 'asdf::relative-pathname)))
 639     (with-open-file (*standard-output*
 640                      (merge-pathnames "DOMTEST" base)
 641                      :direction :output
 642                      :if-exists :supersede)
 643       (run-all-tests directory))))
 644
 645 (defun run-all-tests (*directory* &optional verbose)
 646   (let* ((cxml::*redefinition-warning* nil)
 647          (n 0)
 648          (i 0)
 649          (ntried 0)
 650          (nfailed 0))
 651     (flet ((parse (test-directory)
 652              (let* ((all-tests (merge-pathnames "alltests.xml" test-directory))
 653                     (builder (rune-dom:make-dom-builder))
 654                     (suite (dom:document-element
 655                             (cxml:parse-file all-tests builder :recode nil)))
 656                     (*files-directory*
 657                      (merge-pathnames "files/" test-directory)))
 658                (do-child-elements (member suite)
 659                  (unless
 660                      (or (equal (dom:tag-name member) "metadata")
 661                          (member (runes:rod-string
 662                                   (dom:get-attribute member "href"))
 663                                  *bad-tests*
 664                                  :test 'equal))
 665                    (incf n)))
 666                suite))
 667            (run (test-directory suite)
 668              (print test-directory)
 669              (let ((*files-directory*
 670                     (merge-pathnames "files/" test-directory)))
 671                (do-child-elements (member suite)
 672                  (let ((href (runes:rod-string
 673                               (dom:get-attribute member "href"))))
 674                    (unless (or (runes:rod= (dom:tag-name member) #"metadata")
 675                                (member href *bad-tests* :test 'equal))
 676                      (format t "~&~D/~D ~A~%" i n href)
 677                      (let ((lisp (slurp-test
 678                                   (merge-pathnames href test-directory))))
 679                        (when verbose
 680                          (print lisp))
 681                        (when lisp
 682                          (incf ntried)
 683                          (with-simple-restart (skip-test "Skip this test")
 684                            (handler-case
 685                                (let ((cxml::*validate* nil))
 686                                  (funcall (compile nil lisp)))
 687                              (serious-condition (c)
 688                                (incf nfailed)
 689                                (format t "~&TEST FAILED: ~A~&" c))))))
 690                      (incf i)))))))
 691       (let* ((d1 (merge-pathnames "tests/level1/core/" *directory*))
 692              (d2 (merge-pathnames "tests/level2/core/" *directory*))
 693              (suite1 (parse d1))
 694              (suite2 (parse d2)))
 695         (run d1 suite1)
 696         (run d2 suite2)))
 697     (format t "~&~D/~D tests failed; ~D test~:P were skipped"
 698             nfailed ntried (- n ntried))))
 699
 700 (defun run-test (*directory* level href)
 701   (let* ((test-directory
 702           (ecase level
 703             (1 (merge-pathnames "tests/level1/core/" *directory*))
 704             (2 (merge-pathnames "tests/level2/core/" *directory*))))
 705          (*files-directory* (merge-pathnames "files/" test-directory))
 706          (lisp (slurp-test (merge-pathnames href test-directory)))
 707          (cxml::*validate* nil))
 708     (print lisp)
 709     (fresh-line)
 710     (when lisp
 711       (funcall (compile nil lisp)))))
 712
 713 #+(or)
 714 (domtest::run-all-tests "/home/david/2001/DOM-Test-Suite/")
 715
 716 #+(or)
 717 (domtest::run-test "/home/david/2001/DOM-Test-Suite/"
 718                    1
 719                    "attrcreatedocumentfragment.xml")