-;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
+;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
;;
;; This code is free software; you can redistribute it and/or
;; modify it under the terms of the version 2.1 of
-;; the GNU Lesser General Public License as published by
+;; the GNU Lesser General Public License as published by
;; the Free Software Foundation, as clarified by the AllegroServe
;; prequel found in license-allegroserve.txt.
;;
;; merchantability or fitness for a particular purpose. See the GNU
;; Lesser General Public License for more details.
;;
-;; Version 2.1 of the GNU Lesser General Public License is in the file
+;; Version 2.1 of the GNU Lesser General Public License is in the file
;; license-lgpl.txt that was distributed with this file.
;; If it is not present, you can access it from
;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
-;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
+;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
;; Suite 330, Boston, MA 02111-1307 USA
;;
<!-- this should be <h1>one</h1> string -->
<head>
<style> this should be <h1>one</h1> string </STYLE>
- <title> this is some title text </title>
+ <title> this is some title text </title>
<body> this is some body text
<a name=\"this is an anchor\">with some text </a>
<!-- testing allowing looser attribute parsing -->
'((:html
(:comment "this should be <h1>one</h1> string")
(:head
- (:style "this should be <h1>one</h1> string")
- (:title "this is some title text"))
- (:body
- "this is some body text"
+ (:style "this should be <h1>one</h1> string")
+ (:title "this is some title text"))
+ (:body
+ "this is some body text"
((:a :name "this is an anchor") "with some text")
- (:comment "testing allowing looser attribute parsing")
- ((:a :href "mailto:lmcelroy@performigence.com")
- "lmcelroy@performigence.com")
- :br
- "this is some more text"
- (:bogus "tests parser 'looseness'")
- (:select
- (:option "1")
- (:option "2"))
- (:ul
- (:li "item 1")
- (:li "item 2"))
- (:dl
- (:dt "a term")
- (:dd "its definition")
- (:dt "another term")
- (:dd "another definition"))
- (:table
- (:colgroup
- ((:col :align "right"))
- ((:col :align "center")))
- (:thead
- (:tr
- (:th "this cell is aligned right")
- (:th "this cell is centered")))
- (:tfoot
- (:tr
- (:th "this cell is aligned right")
- (:th "this cell is centered")))
- (:tbody
- (:tr
- (:td "this cell is aligned right")
- (:td "this cell is centered")))
- (:tbody
- (:tr
- (:td "this cell is aligned right")
- (:td "this cell is centered"))))
- (:pp
- (:object
- (:pp "Navigate the site:"
- ((:map :name "mainmap")
- ((:area :shape "rect" :coords "0,100,100,200"))
- ((:area :shape "rect" :coords "100,100,100,200"))))))
- (:abbr "WWW")
- "is an abbreviation"
- (:b "force")
- (:pp "whitespace only")
- ))))
+ (:comment "testing allowing looser attribute parsing")
+ ((:a :href "mailto:lmcelroy@performigence.com")
+ "lmcelroy@performigence.com")
+ :br
+ "this is some more text"
+ (:bogus "tests parser 'looseness'")
+ (:select
+ (:option "1")
+ (:option "2"))
+ (:ul
+ (:li "item 1")
+ (:li "item 2"))
+ (:dl
+ (:dt "a term")
+ (:dd "its definition")
+ (:dt "another term")
+ (:dd "another definition"))
+ (:table
+ (:colgroup
+ ((:col :align "right"))
+ ((:col :align "center")))
+ (:thead
+ (:tr
+ (:th "this cell is aligned right")
+ (:th "this cell is centered")))
+ (:tfoot
+ (:tr
+ (:th "this cell is aligned right")
+ (:th "this cell is centered")))
+ (:tbody
+ (:tr
+ (:td "this cell is aligned right")
+ (:td "this cell is centered")))
+ (:tbody
+ (:tr
+ (:td "this cell is aligned right")
+ (:td "this cell is centered"))))
+ (:pp
+ (:object
+ (:pp "Navigate the site:"
+ ((:map :name "mainmap")
+ ((:area :shape "rect" :coords "0,100,100,200"))
+ ((:area :shape "rect" :coords "100,100,100,200"))))))
+ (:abbr "WWW")
+ "is an abbreviation"
+ (:b "force")
+ (:pp "whitespace only")
+ ))))
(setf *test-string2*
"<i><b id=1>text</i> more text</b>
(setf *test-string3*
"<ICMETA URL='nytimes.html'>
<NYT_HEADER version='1.0' type='homepage'>
-<body bgcolor='#ffffff' background='back5.gif'
+<body bgcolor='#ffffff' background='back5.gif'
vlink='4' link='6'>
<NYT_BANNER version='1.0' type='homepage'>
<table border=0 cellspacing=0 cellpadding=0>
((:table :border "0" :cellspacing "0" :cellpadding "0")
(:tr
((:td :bgcolor "0" :rowspan "4" :width "126" :align "left" :valign "center")
- ((:nyt_ad :version "1.0" :location "")
- ((:a :href "ads.gif" :target "top")
- ((:img :src "http://ads2.gif" :border "0" :width "120" :height "90" :alt
- "E-Mail Updates from NYTimes.com"))))))))))
+ ((:nyt_ad :version "1.0" :location "")
+ ((:a :href "ads.gif" :target "top")
+ ((:img :src "http://ads2.gif" :border "0" :width "120" :height "90" :alt
+ "E-Mail Updates from NYTimes.com"))))))))))
(defmethod lhtml-equal ((a t) (b t))
(loop
(if* (and (= i (length a)) (= j (length b))) then (return t)
elseif (and (< i (length a)) (white-space-p (nth i a))) then
- (incf i)
+ (incf i)
elseif (white-space-p (nth j b)) then
- (incf j)
+ (incf j)
elseif (and (= i (length a)) (/= j (length b))) then
- (return
- (loop
- (when (= j (length b)) (return t))
- (when (not (white-space-p (nth j b))) (return nil))
- (incf j)))
+ (return
+ (loop
+ (when (= j (length b)) (return t))
+ (when (not (white-space-p (nth j b))) (return nil))
+ (incf j)))
elseif (and (/= i (length a)) (= j (length b))) then
- (return
- (loop
- (when (= i (length a)) (return t))
- (when (not (white-space-p (nth i a))) (return nil))
- (incf i)))
+ (return
+ (loop
+ (when (= i (length a)) (return t))
+ (when (not (white-space-p (nth i a))) (return nil))
+ (incf i)))
elseif (not (lhtml-equal (nth i a) (nth j b))) then
- (return nil)
- else
- (incf i)
- (incf j)))))
+ (return nil)
+ else
+ (incf i)
+ (incf j)))))
(defmethod lhtml-equal ((a string) (b string))
(let ((i 0) (j 0))
;; skip white space in beginning
(loop
(let ((char (elt a i)))
- (when (and (not (eq char #\space))
- (not (eq char #\tab))
- (not (eq char #\return))
- (not (eq char #\linefeed)))
- (return)))
+ (when (and (not (eq char #\space))
+ (not (eq char #\tab))
+ (not (eq char #\return))
+ (not (eq char #\linefeed)))
+ (return)))
(incf i))
(loop
(let ((char (elt b j)))
- (when (and (not (eq char #\space))
- (not (eq char #\tab))
- (not (eq char #\return))
- (not (eq char #\linefeed)))
- (return)))
+ (when (and (not (eq char #\space))
+ (not (eq char #\tab))
+ (not (eq char #\return))
+ (not (eq char #\linefeed)))
+ (return)))
(incf j))
(loop
(when (and (= i (length a)) (= j (length b))) (return t))
(when (and (= i (length a)) (/= j (length b)))
- (return
- (loop
- (when (= j (length b)) (return t))
- (let ((char (elt b j)))
- (when (and (not (eq char #\space))
- (not (eq char #\tab))
- (not (eq char #\return))
- (not (eq char #\linefeed)))
- (return t)))
- (incf j))))
+ (return
+ (loop
+ (when (= j (length b)) (return t))
+ (let ((char (elt b j)))
+ (when (and (not (eq char #\space))
+ (not (eq char #\tab))
+ (not (eq char #\return))
+ (not (eq char #\linefeed)))
+ (return t)))
+ (incf j))))
(when (and (/= i (length a)) (= j (length b)))
- (return
- (loop
- (when (= i (length a)) (return t))
- (let ((char (elt a i)))
- (when (and (not (eq char #\space))
- (not (eq char #\tab))
- (not (eq char #\return))
- (not (eq char #\linefeed)))
- (return t)))
- (incf i))))
+ (return
+ (loop
+ (when (= i (length a)) (return t))
+ (let ((char (elt a i)))
+ (when (and (not (eq char #\space))
+ (not (eq char #\tab))
+ (not (eq char #\return))
+ (not (eq char #\linefeed)))
+ (return t)))
+ (incf i))))
(when (not (eq (elt a i) (elt b j))) (return nil))
(incf i)
(incf j))))
(defmethod white-space-p ((a string))
(let ((i 0)
- (length (length a)))
+ (length (length a)))
(loop
(when (= i length) (return t))
(let ((char (elt a i)))
- (when (and (not (eq char #\space))
- (not (eq char #\tab))
- (not (eq char #\return))
- (not (eq char #\linefeed)))
- (return nil)))
+ (when (and (not (eq char #\space))
+ (not (eq char #\tab))
+ (not (eq char #\return))
+ (not (eq char #\linefeed)))
+ (return nil)))
(incf i))))
;;------------------------------------------------
(incf *callback-called*)
(if* (= *pass* 0)
then
- (incf *pass*)
- (test t (lhtml-equal arg
- '((:a :name "this is an anchor")
- "with some text")))
+ (incf *pass*)
+ (test t (lhtml-equal arg
+ '((:a :name "this is an anchor")
+ "with some text")))
else
- (setf *pass* 0)
- (test t (lhtml-equal arg
- '((:a :href
- "mailto:lmcelroy@performigence.com")
- "lmcelroy@performigence.com"))))))
+ (setf *pass* 0)
+ (test t (lhtml-equal arg
+ '((:a :href
+ "mailto:lmcelroy@performigence.com")
+ "lmcelroy@performigence.com"))))))
(let ((*pass* 0))
(defun nested-callback (arg)
(incf *callback-called*)
(if* (= *pass* 0)
then
- (incf *pass*)
- (test t (lhtml-equal arg
- '(:pp "Navigate the site:"
- ((:map :name "mainmap")
- ((:area :shape "rect" :coords "0,100,100,200"))
- ((:area :shape "rect" :coords "100,100,100,200"))))))
+ (incf *pass*)
+ (test t (lhtml-equal arg
+ '(:pp "Navigate the site:"
+ ((:map :name "mainmap")
+ ((:area :shape "rect" :coords "0,100,100,200"))
+ ((:area :shape "rect" :coords "100,100,100,200"))))))
elseif (= *pass* 1)
then
- (incf *pass*)
- (test t (lhtml-equal arg
- '(:pp
- (:object
- (:pp "Navigate the site:"
- ((:map :name "mainmap")
- ((:area :shape "rect" :coords "0,100,100,200"))
- ((:area :shape "rect"
- :coords "100,100,100,200"))))))))
+ (incf *pass*)
+ (test t (lhtml-equal arg
+ '(:pp
+ (:object
+ (:pp "Navigate the site:"
+ ((:map :name "mainmap")
+ ((:area :shape "rect" :coords "0,100,100,200"))
+ ((:area :shape "rect"
+ :coords "100,100,100,200"))))))))
else
- (setf *pass* 0)
- (test t (lhtml-equal arg
- '(:pp "whitespace only"))))))
+ (setf *pass* 0)
+ (test t (lhtml-equal arg
+ '(:pp "whitespace only"))))))
(defun testit ()
(let ((util.test:*test-errors* 0)
- (util.test:*test-successes* 0))
+ (util.test:*test-successes* 0))
(test t (lhtml-equal (parse-html *test-string2*) *expected-result2*))
(setf *callback-called* 0)
(test t (lhtml-equal (parse-html *test-string*) *expected-result*))
(test 0 *callback-called*)
;;(setf (element-callback :a) 'callback-test-func)
(setf *callback-called* 0)
- (test t (lhtml-equal (parse-html *test-string*
- :callbacks (acons :a 'callback-test-func nil))
- *expected-result*))
+ (test t (lhtml-equal (parse-html *test-string*
+ :callbacks (acons :a 'callback-test-func nil))
+ *expected-result*))
(test 2 *callback-called*)
(setf *callback-called* 0)
(test t (lhtml-equal (parse-html *test-string*) *expected-result*))
(setf *callback-called* 0)
;; make sure function is OK arg
;;(setf (element-callback :a) (symbol-function 'callback-test-func))
- (test t (lhtml-equal
- (parse-html *test-string*
- :callbacks (acons :a (symbol-function 'callback-test-func) nil))
- *expected-result*))
+ (test t (lhtml-equal
+ (parse-html *test-string*
+ :callbacks (acons :a (symbol-function 'callback-test-func) nil))
+ *expected-result*))
(test 2 *callback-called*)
;; try with :callback-only t
(setf *callback-called* 0)
;;(setf (element-callback :a) 'callback-test-func)
(parse-html *test-string* :callback-only t
- :callbacks (acons :a 'callback-test-func nil)) ;; won't return parse output
+ :callbacks (acons :a 'callback-test-func nil)) ;; won't return parse output
(test 2 *callback-called*)
;; try nested callback
(setf *callback-called* 0)
;;(setf (element-callback :p) 'nested-callback)
(test t (lhtml-equal (parse-html *test-string*
- :callbacks (acons :pp 'nested-callback nil))
- *expected-result*))
+ :callbacks (acons :pp 'nested-callback nil))
+ *expected-result*))
(test 3 *callback-called*)
(setf *callback-called* 0)
(parse-html *test-string* :callback-only t
- :callbacks (acons :pp 'nested-callback nil))
+ :callbacks (acons :pp 'nested-callback nil))
(test 3 *callback-called*)
(test-error (parse-html "b<a"))
(test t (lhtml-equal
- (multiple-value-bind (res rogues)
- (parse-html *test-string3* :collect-rogue-tags t)
- (declare (ignorable res))
- (parse-html *test-string3* :no-body-tags rogues))
- *expected-result3*))
+ (multiple-value-bind (res rogues)
+ (parse-html *test-string3* :collect-rogue-tags t)
+ (declare (ignorable res))
+ (parse-html *test-string3* :no-body-tags rogues))
+ *expected-result3*))
(format t "End test: ~s, ~d errors, ~d successes~%"
- "parse-html" util.test:*test-errors* util.test:*test-successes*)
+ "parse-html" util.test:*test-errors* util.test:*test-successes*)
))
projects / xmlutils.git / blobdiff