")
(setf *expected-result3*
'(((:icmeta :url "nytimes.html")) ((:nyt_header :version "1.0" :type "homepage"))
((:body :bgcolor "#ffffff" :background "back5.gif" :vlink "4" :link "6")
((:nyt_banner :version "1.0" :type "homepage"))
((: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"))))))))))
(defgeneric lhtml-equal (a b))
(defmethod lhtml-equal ((a t) (b t))
(equal a b))
(defmethod lhtml-equal ((a list) (b list))
(let ((i 0) (j 0))
(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)
elseif (white-space-p (nth j b)) then
(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)))
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)))
elseif (not (lhtml-equal (nth i a) (nth j b))) then
(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)))
(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)))
(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))))
(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))))
(when (not (eq (elt a i) (elt b j))) (return nil))
(incf i)
(incf j))))
(defgeneric white-space-p (thing))
(defmethod white-space-p ((a t))
nil)
(defmethod white-space-p ((a string))
(let ((i 0)
(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)))
(incf i))))
;;------------------------------------------------
(defvar *callback-called* 0)
(let ((*pass* 0))
(defun callback-test-func (arg)
;; incf *callback-called* so we know exactly how many times this is
;; called
(incf *callback-called*)
(if* (= *pass* 0)
then
(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"))))))
(let ((*pass* 0))
(defun nested-callback (arg)
;; incf *callback-called* so we know exactly how many times this is
;; called
(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"))))))
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"))))))))
else
(setf *pass* 0)
(test t (lhtml-equal arg
'(:pp "whitespace only"))))))
(defun testit ()
(let ((#+allegro util.test:*test-errors*
#-allegro ptester:*test-errors* 0)
(#+allegro util.test:*test-successes*
#-allegro ptester:*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 2 *callback-called*)
(setf *callback-called* 0)
(test t (lhtml-equal (parse-html *test-string*) *expected-result*))
(test 0 *callback-called*)
(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 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
(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*))
(test 3 *callback-called*)
(setf *callback-called* 0)
(parse-html *test-string* :callback-only t
:callbacks (acons :pp 'nested-callback nil))
(test 3 *callback-called*)
(test-error (parse-html "b |
