1 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
3 ;; This code is free software; you can redistribute it and/or
4 ;; modify it under the terms of the version 2.1 of
5 ;; the GNU Lesser General Public License as published by
6 ;; the Free Software Foundation, as clarified by the AllegroServe
7 ;; prequel found in license-allegroserve.txt.
9 ;; This code is distributed in the hope that it will be useful,
10 ;; but without any warranty; without even the implied warranty of
11 ;; merchantability or fitness for a particular purpose. See the GNU
12 ;; Lesser General Public License for more details.
14 ;; Version 2.1 of the GNU Lesser General Public License is in the file
15 ;; license-lgpl.txt that was distributed with this file.
16 ;; If it is not present, you can access it from
17 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
18 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
19 ;; Suite 330, Boston, MA 02111-1307 USA
22 ;; $Id: phtml-test.cl,v 1.1 2002/10/15 12:23:03 kevin Exp $
24 (eval-when (compile load eval)
27 (defpackage :user (:use :util.test :net.html.parser)) ;; assumes phtml.cl loaded
30 (defvar *test-string*)
31 (defvar *test-string2*)
32 (defvar *test-string3*)
33 (defvar *expected-result*)
34 (defvar *expected-result2*)
35 (defvar *expected-result3*)
38 ;; it uses a fake pp tag to test nesting for callbacks...
41 <!-- this should be <h1>one</h1> string -->
43 <style> this should be <h1>one</h1> string </STYLE>
44 <title> this is some title text </title>
45 <body> this is some body text
46 <a name=\"this is an anchor\">with some text </a>
47 <!-- testing allowing looser attribute parsing -->
48 <a href= mailto:lmcelroy@performigence.com>lmcelroy@performigence.com
51 this is some more text
52 <bogus> tests parser 'looseness'</bogus>
63 <dd>another definition</dl>
67 <col align=\"center\">
70 <th> this cell is aligned right
71 <th> this cell is centered
74 <th> this cell is aligned right
75 <th> this cell is centered
78 <td> this cell is aligned right
79 <td> this cell is centered
82 <td> this cell is aligned right
83 <td> this cell is centered </table>
86 <pp>Navigate the site:
87 <map name=\"mainmap\">
88 <area shape=rect coords=\"0,100,100,200\">
89 <area shape=rect coords=\"100,100,100,200\"> </map> </object> </pp>
90 <abbr>WWW</abbr> is an abbreviation
94 (setf *expected-result*
96 (:comment "this should be <h1>one</h1> string")
98 (:style "this should be <h1>one</h1> string")
99 (:title "this is some title text"))
101 "this is some body text"
102 ((:a :name "this is an anchor") "with some text")
103 (:comment "testing allowing looser attribute parsing")
104 ((:a :href "mailto:lmcelroy@performigence.com")
105 "lmcelroy@performigence.com")
107 "this is some more text"
108 (:bogus "tests parser 'looseness'")
117 (:dd "its definition")
119 (:dd "another definition"))
122 ((:col :align "right"))
123 ((:col :align "center")))
126 (:th "this cell is aligned right")
127 (:th "this cell is centered")))
130 (:th "this cell is aligned right")
131 (:th "this cell is centered")))
134 (:td "this cell is aligned right")
135 (:td "this cell is centered")))
138 (:td "this cell is aligned right")
139 (:td "this cell is centered"))))
142 (:pp "Navigate the site:"
143 ((:map :name "mainmap")
144 ((:area :shape "rect" :coords "0,100,100,200"))
145 ((:area :shape "rect" :coords "100,100,100,200"))))))
149 (:pp "whitespace only")
153 "<i><b id=1>text</i> more text</b>
154 <!doctype this is some text>
156 <i><b>text</i></b> more text
157 <b>text<p>more text</b> yet more text</p>
158 <ul><li><b>text<li>more text</ul></b>
159 prev<b><a href=foo>bar</a>baz</b>
160 <b>foo<a>bar</a>baz</b>
161 <b>foo<a>bar</b>baz</a>
162 <b>foo<script>bar</script><a>baz</a></b>
163 <b>foo<i>bar</i>baz</b>
164 <script a=b> some text if (year < 1000) year += 1900; more text </script>
165 <script a=b></script>
166 <frameset><frame foo><frame bar></frameset>"
169 (setf *expected-result2*
170 '((:i ((:b :id "1") "text")) ((:b :id "1") " more text")
171 (:!doctype "this is some text")
173 (:i (:b "text")) (:b) " more text"
174 (:b "text") (:p (:b "more text") " yet more text")
175 (:ul (:li (:b "text")) (:li (:b "more text"))) (:b)
176 "prev" (:b ((:a :href "foo") "bar") "baz")
177 (:b "foo" (:a "bar") "baz")
178 (:b "foo") (:a (:b "bar") "baz")
179 (:b "foo") (:script "bar") (:b (:a "baz"))
180 (:b "foo" (:i "bar") "baz")
181 ((:script :a "b") " some text if (year < 1000) year += 1900; more text ")
183 (:frameset ((:frame :foo "foo")) ((:frame :bar "bar")))
187 "<ICMETA URL='nytimes.html'>
188 <NYT_HEADER version='1.0' type='homepage'>
189 <body bgcolor='#ffffff' background='back5.gif'
191 <NYT_BANNER version='1.0' type='homepage'>
192 <table border=0 cellspacing=0 cellpadding=0>
194 <td bgcolor=0 rowspan=4 width=126 align=left valign=center>
195 <NYT_AD version='1.0' location=''>
196 <A HREF='ads.gif' target='top'>
197 <IMG SRC='http://ads2.gif' BORDER=0 WIDTH=120 HEIGHT=90 ALT='E-Mail Updates from NYTimes.com' ></A>
200 (setf *expected-result3*
201 '(((:icmeta :url "nytimes.html")) ((:nyt_header :version "1.0" :type "homepage"))
202 ((:body :bgcolor "#ffffff" :background "back5.gif" :vlink "4" :link "6")
203 ((:nyt_banner :version "1.0" :type "homepage"))
204 ((:table :border "0" :cellspacing "0" :cellpadding "0")
206 ((:td :bgcolor "0" :rowspan "4" :width "126" :align "left" :valign "center")
207 ((:nyt_ad :version "1.0" :location "")
208 ((:a :href "ads.gif" :target "top")
209 ((:img :src "http://ads2.gif" :border "0" :width "120" :height "90" :alt
210 "E-Mail Updates from NYTimes.com"))))))))))
213 (defmethod lhtml-equal ((a t) (b t))
216 (defmethod lhtml-equal ((a list) (b list))
219 (if* (and (= i (length a)) (= j (length b))) then (return t)
220 elseif (and (< i (length a)) (white-space-p (nth i a))) then
222 elseif (white-space-p (nth j b)) then
224 elseif (and (= i (length a)) (/= j (length b))) then
227 (when (= j (length b)) (return t))
228 (when (not (white-space-p (nth j b))) (return nil))
230 elseif (and (/= i (length a)) (= j (length b))) then
233 (when (= i (length a)) (return t))
234 (when (not (white-space-p (nth i a))) (return nil))
236 elseif (not (lhtml-equal (nth i a) (nth j b))) then
242 (defmethod lhtml-equal ((a string) (b string))
244 ;; skip white space in beginning
246 (let ((char (elt a i)))
247 (when (and (not (eq char #\space))
248 (not (eq char #\tab))
249 (not (eq char #\return))
250 (not (eq char #\linefeed)))
254 (let ((char (elt b j)))
255 (when (and (not (eq char #\space))
256 (not (eq char #\tab))
257 (not (eq char #\return))
258 (not (eq char #\linefeed)))
262 (when (and (= i (length a)) (= j (length b))) (return t))
263 (when (and (= i (length a)) (/= j (length b)))
266 (when (= j (length b)) (return t))
267 (let ((char (elt b j)))
268 (when (and (not (eq char #\space))
269 (not (eq char #\tab))
270 (not (eq char #\return))
271 (not (eq char #\linefeed)))
274 (when (and (/= i (length a)) (= j (length b)))
277 (when (= i (length a)) (return t))
278 (let ((char (elt a i)))
279 (when (and (not (eq char #\space))
280 (not (eq char #\tab))
281 (not (eq char #\return))
282 (not (eq char #\linefeed)))
285 (when (not (eq (elt a i) (elt b j))) (return nil))
289 (defmethod white-space-p ((a t))
292 (defmethod white-space-p ((a string))
296 (when (= i length) (return t))
297 (let ((char (elt a i)))
298 (when (and (not (eq char #\space))
299 (not (eq char #\tab))
300 (not (eq char #\return))
301 (not (eq char #\linefeed)))
305 ;;------------------------------------------------
307 (defvar *callback-called* 0)
310 (defun callback-test-func (arg)
311 ;; incf *callback-called* so we know exactly how many times this is
313 (incf *callback-called*)
317 (test t (lhtml-equal arg
318 '((:a :name "this is an anchor")
322 (test t (lhtml-equal arg
324 "mailto:lmcelroy@performigence.com")
325 "lmcelroy@performigence.com"))))))
328 (defun nested-callback (arg)
329 ;; incf *callback-called* so we know exactly how many times this is
331 (incf *callback-called*)
335 (test t (lhtml-equal arg
336 '(:pp "Navigate the site:"
337 ((:map :name "mainmap")
338 ((:area :shape "rect" :coords "0,100,100,200"))
339 ((:area :shape "rect" :coords "100,100,100,200"))))))
343 (test t (lhtml-equal arg
346 (:pp "Navigate the site:"
347 ((:map :name "mainmap")
348 ((:area :shape "rect" :coords "0,100,100,200"))
349 ((:area :shape "rect"
350 :coords "100,100,100,200"))))))))
353 (test t (lhtml-equal arg
354 '(:pp "whitespace only"))))))
357 (let ((util.test:*test-errors* 0)
358 (util.test:*test-successes* 0))
359 (test t (lhtml-equal (parse-html *test-string2*) *expected-result2*))
360 (setf *callback-called* 0)
361 (test t (lhtml-equal (parse-html *test-string*) *expected-result*))
362 (test 0 *callback-called*)
363 ;;(setf (element-callback :a) 'callback-test-func)
364 (setf *callback-called* 0)
365 (test t (lhtml-equal (parse-html *test-string*
366 :callbacks (acons :a 'callback-test-func nil))
368 (test 2 *callback-called*)
369 (setf *callback-called* 0)
370 (test t (lhtml-equal (parse-html *test-string*) *expected-result*))
371 (test 0 *callback-called*)
372 (setf *callback-called* 0)
373 ;; make sure function is OK arg
374 ;;(setf (element-callback :a) (symbol-function 'callback-test-func))
376 (parse-html *test-string*
377 :callbacks (acons :a (symbol-function 'callback-test-func) nil))
379 (test 2 *callback-called*)
380 ;; try with :callback-only t
381 (setf *callback-called* 0)
382 ;;(setf (element-callback :a) 'callback-test-func)
383 (parse-html *test-string* :callback-only t
384 :callbacks (acons :a 'callback-test-func nil)) ;; won't return parse output
385 (test 2 *callback-called*)
386 ;; try nested callback
387 (setf *callback-called* 0)
388 ;;(setf (element-callback :p) 'nested-callback)
389 (test t (lhtml-equal (parse-html *test-string*
390 :callbacks (acons :pp 'nested-callback nil))
392 (test 3 *callback-called*)
393 (setf *callback-called* 0)
394 (parse-html *test-string* :callback-only t
395 :callbacks (acons :pp 'nested-callback nil))
396 (test 3 *callback-called*)
397 (test-error (parse-html "b<a"))
399 (multiple-value-bind (res rogues)
400 (parse-html *test-string3* :collect-rogue-tags t)
401 (declare (ignorable res))
402 (parse-html *test-string3* :no-body-tags rogues))
404 (format t "End test: ~s, ~d errors, ~d successes~%"
405 "parse-html" util.test:*test-errors* util.test:*test-successes*)