phtml-test.cl

   1 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
   2 ;;
   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.
   8 ;;
   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.
  13 ;;
  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
  20 ;;
  21
  22 ;; $Id$
  23
  24 (eval-when (compile load eval)
  25   (require :tester))
  26
  27 (defpackage :user (:use :util.test :net.html.parser))  ;; assumes phtml.cl loaded
  28 (in-package :user)
  29
  30 (defvar *test-string*)
  31 (defvar *test-string2*)
  32 (defvar *test-string3*)
  33 (defvar *expected-result*)
  34 (defvar *expected-result2*)
  35 (defvar *expected-result3*)
  36
  37
  38 ;; it uses a fake pp tag to test nesting for callbacks...
  39 (setf *test-string*
  40     "<html>
  41        <!-- this should be <h1>one</h1> string -->
  42        <head>
  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
  49            </a>
  50         <br>
  51         this is some more text
  52         <bogus> tests parser 'looseness'</bogus>
  53         <select>
  54          <option>1
  55          <option>2 </select>
  56         <ul>
  57          <li>item 1
  58          <li>item 2 </ul>
  59         <dl>
  60          <dt>a term
  61          <dd>its definition
  62          <dt>another term
  63          <dd>another definition</dl>
  64         <table>
  65          <colgroup>
  66           <col align=\"right\">
  67           <col align=\"center\">
  68          <thead>
  69          <tr>
  70           <th> this cell is aligned right
  71           <th> this cell is centered
  72          <tfoot>
  73          <tr>
  74           <th> this cell is aligned right
  75           <th> this cell is centered
  76          <tbody>
  77          <tr>
  78           <td> this cell is aligned right
  79           <td> this cell is centered
  80          <tbody>
  81          <tr>
  82           <td> this cell is aligned right
  83           <td> this cell is centered </table>
  84         <pp>
  85          <object>
  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
  91         <b>force</b>
  92         <pp>whitespace only")
  93
  94 (setf *expected-result*
  95     '((:html
  96        (:comment "this should be <h1>one</h1> string")
  97        (:head
  98         (:style "this should be <h1>one</h1> string")
  99         (:title "this is some title text"))
 100        (:body
 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")
 106         :br
 107         "this is some more text"
 108         (:bogus "tests parser 'looseness'")
 109         (:select
 110          (:option "1")
 111          (:option "2"))
 112         (:ul
 113          (:li "item 1")
 114          (:li "item 2"))
 115         (:dl
 116          (:dt "a term")
 117          (:dd "its definition")
 118          (:dt "another term")
 119          (:dd "another definition"))
 120         (:table
 121          (:colgroup
 122           ((:col :align "right"))
 123           ((:col :align "center")))
 124          (:thead
 125           (:tr
 126            (:th "this cell is aligned right")
 127            (:th "this cell is centered")))
 128          (:tfoot
 129           (:tr
 130            (:th "this cell is aligned right")
 131            (:th "this cell is centered")))
 132          (:tbody
 133           (:tr
 134            (:td "this cell is aligned right")
 135            (:td "this cell is centered")))
 136          (:tbody
 137           (:tr
 138            (:td "this cell is aligned right")
 139            (:td "this cell is centered"))))
 140         (:pp
 141          (:object
 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"))))))
 146         (:abbr "WWW")
 147         "is an abbreviation"
 148         (:b "force")
 149         (:pp "whitespace only")
 150         ))))
 151
 152 (setf *test-string2*
 153   "<i><b id=1>text</i> more text</b>
 154    <!doctype this is some text>
 155    <![if xxx]>
 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>"
 167   )
 168
 169 (setf *expected-result2*
 170   '((:i ((:b :id "1") "text")) ((:b :id "1") " more text")
 171     (:!doctype "this is some text")
 172     (:! "[if xxx]")
 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 ")
 182     ((:script :a "b"))
 183     (:frameset ((:frame :foo "foo")) ((:frame :bar "bar")))
 184     ))
 185
 186 (setf *test-string3*
 187   "<ICMETA URL='nytimes.html'>
 188 <NYT_HEADER version='1.0' type='homepage'>
 189 <body bgcolor='#ffffff' background='back5.gif'
 190 vlink='4' link='6'>
 191 <NYT_BANNER version='1.0' type='homepage'>
 192 <table border=0 cellspacing=0 cellpadding=0>
 193 <tr>
 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>
 198 </NYT_AD>")
 199
 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")
 205       (:tr
 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"))))))))))
 211
 212
 213 (defmethod lhtml-equal ((a t) (b t))
 214   (equal a b))
 215
 216 (defmethod lhtml-equal ((a list) (b list))
 217   (let ((i 0) (j 0))
 218     (loop
 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
 221               (incf i)
 222        elseif (white-space-p (nth j b)) then
 223               (incf j)
 224        elseif (and (= i (length a)) (/= j (length b))) then
 225               (return
 226                 (loop
 227                   (when (= j (length b)) (return t))
 228                   (when (not (white-space-p (nth j b))) (return nil))
 229                   (incf j)))
 230        elseif (and (/= i (length a)) (= j (length b))) then
 231               (return
 232                 (loop
 233                   (when (= i (length a)) (return t))
 234                   (when (not (white-space-p (nth i a))) (return nil))
 235                   (incf i)))
 236        elseif (not (lhtml-equal (nth i a) (nth j b))) then
 237               (return nil)
 238          else
 239               (incf i)
 240               (incf j)))))
 241
 242 (defmethod lhtml-equal ((a string) (b string))
 243   (let ((i 0) (j 0))
 244     ;; skip white space in beginning
 245     (loop
 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)))
 251           (return)))
 252       (incf i))
 253     (loop
 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)))
 259           (return)))
 260       (incf j))
 261     (loop
 262       (when (and (= i (length a)) (= j (length b))) (return t))
 263       (when (and (= i (length a)) (/= j (length b)))
 264         (return
 265           (loop
 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)))
 272                 (return t)))
 273             (incf j))))
 274       (when (and (/= i (length a)) (= j (length b)))
 275         (return
 276           (loop
 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)))
 283                 (return t)))
 284             (incf i))))
 285       (when (not (eq (elt a i) (elt b j))) (return nil))
 286       (incf i)
 287       (incf j))))
 288
 289 (defmethod white-space-p ((a t))
 290   nil)
 291
 292 (defmethod white-space-p ((a string))
 293   (let ((i 0)
 294         (length (length a)))
 295     (loop
 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)))
 302           (return nil)))
 303       (incf i))))
 304
 305 ;;------------------------------------------------
 306
 307 (defvar *callback-called* 0)
 308
 309 (let ((*pass* 0))
 310   (defun callback-test-func (arg)
 311     ;; incf *callback-called* so we know exactly how many times this is
 312     ;; called
 313     (incf *callback-called*)
 314     (if* (= *pass* 0)
 315        then
 316             (incf *pass*)
 317             (test t (lhtml-equal arg
 318                                  '((:a :name "this is an anchor")
 319                                    "with some text")))
 320        else
 321             (setf *pass* 0)
 322             (test t (lhtml-equal arg
 323                                  '((:a :href
 324                                        "mailto:lmcelroy@performigence.com")
 325                                    "lmcelroy@performigence.com"))))))
 326
 327 (let ((*pass* 0))
 328   (defun nested-callback (arg)
 329     ;; incf *callback-called* so we know exactly how many times this is
 330     ;; called
 331     (incf *callback-called*)
 332     (if* (= *pass* 0)
 333        then
 334             (incf *pass*)
 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"))))))
 340      elseif (= *pass* 1)
 341        then
 342             (incf *pass*)
 343             (test t (lhtml-equal arg
 344                                  '(:pp
 345                                    (:object
 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"))))))))
 351        else
 352             (setf *pass* 0)
 353             (test t (lhtml-equal arg
 354                                  '(:pp "whitespace only"))))))
 355
 356 (defun testit ()
 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))
 367                          *expected-result*))
 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))
 375     (test t (lhtml-equal
 376              (parse-html *test-string*
 377                          :callbacks (acons :a (symbol-function 'callback-test-func) nil))
 378                          *expected-result*))
 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))
 391                          *expected-result*))
 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"))
 398     (test t (lhtml-equal
 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))
 403              *expected-result3*))
 404     (format t "End test: ~s,   ~d errors, ~d successes~%"
 405             "parse-html" util.test:*test-errors* util.test:*test-successes*)
 406     ))