phtml.cl

   1 #+allegro
   2 (sys:defpatch "phtml" 1
   3   "parse-html close tag closes consecutive identical open tags."
   4   :type :system
   5   :post-loadable t)
   6
   7 ;; copyright (c) 1986-2000 Franz Inc, Berkeley, CA
   8 ;;
   9 ;; This code is free software; you can redistribute it and/or
  10 ;; modify it under the terms of the version 2.1 of
  11 ;; the GNU Lesser General Public License as published by
  12 ;; the Free Software Foundation, as clarified by the AllegroServe
  13 ;; prequel found in license-allegroserve.txt.
  14 ;;
  15 ;; This code is distributed in the hope that it will be useful,
  16 ;; but without any warranty; without even the implied warranty of
  17 ;; merchantability or fitness for a particular purpose.  See the GNU
  18 ;; Lesser General Public License for more details.
  19 ;;
  20 ;; Version 2.1 of the GNU Lesser General Public License is in the file
  21 ;; license-lgpl.txt that was distributed with this file.
  22 ;; If it is not present, you can access it from
  23 ;; http://www.gnu.org/copyleft/lesser.txt (until superseded by a newer
  24 ;; version) or write to the Free Software Foundation, Inc., 59 Temple Place,
  25 ;; Suite 330, Boston, MA  02111-1307  USA
  26 ;;
  27
  28 ;; $Id$
  29
  30 ;; phtml.cl  - parse html
  31
  32 ;; Change Log
  33 ;; 05/14/02 - add :parse-entities arg to parse-html. If true then
  34 ;;         entities are converted to the character they represent.
  35 ;;
  36 ;; 02/05/01 symbols mapped to preferred case at runtime (as opposed to
  37 ;;            a compile time macro determining the case mapping)
  38 ;;
  39 ;; 10/27/00 :callbacks arg now processed correctly for tags with no body
  40 ;;
  41 ;; 10/14/00 add first-pass member to tokenbuf structure; used to remove
  42 ;;             multiple un-next-char calls in raw mode
  43 ;;          removed :script from *in-line* (incorect and led to infinite loop)
  44 ;;          char format reopen not done in :script and :style
  45 ;;          fixed :table/:th tag-auto-close-stop typo
  46
  47
  48 ; do character entity stuff
  49 ;
  50
  51 (defpackage net.html.parser
  52   (:use :cl #+allegro :clos :excl #+allegro :mp #-allegro :acl-mp)
  53   (:export
  54    #:phtml-internal
  55    #:parse-html))
  56
  57 (in-package :net.html.parser)
  58
  59 (defmacro tag-auto-close (tag) `(get ,tag 'tag-auto-close))
  60 (defmacro tag-auto-close-stop (tag) `(get ,tag 'tag-auto-close-stop))
  61 (defmacro tag-no-end (tag) `(get ,tag 'tag-no-end))
  62
  63 ; only subelements allowed in this element, no strings
  64 (defmacro tag-no-pcdata (tag) `(get ,tag 'tag-no-pcdata))
  65
  66 ;; given :foo or (:foo ...) return :foo
  67 (defmacro tag-name (expr)
  68   `(let ((.xx. ,expr))
  69      (if* (consp .xx.)
  70         then (car .xx.)
  71         else .xx.)))
  72
  73
  74
  75
  76
  77 (eval-when (compile load eval)
  78   (defconstant state-pcdata 0) ; scanning for chars or a tag
  79   (defconstant state-readtagfirst 1)
  80   (defconstant state-readtag      2)
  81   (defconstant state-findattribname 3)
  82   (defconstant state-attribname    4)
  83   (defconstant state-attribstartvalue 5)
  84   (defconstant state-attribvaluedelim 6)
  85   (defconstant state-attribvaluenodelim 7)
  86   (defconstant state-readcomment 8)
  87   (defconstant state-readcomment-one 9)
  88   (defconstant state-readcomment-two 10)
  89   (defconstant state-findvalue 11)
  90   (defconstant state-rawdata 12)
  91 )
  92
  93
  94 (defstruct collector
  95   next  ; next index to set
  96   max   ; 1+max index to set
  97   data  ; string vector
  98   )
  99
 100 ;; keep a cache of collectors on this list
 101
 102 (defparameter *collectors* (list nil nil nil nil))
 103
 104 (defun get-collector ()
 105   (declare (optimize (speed 3) (safety 1)))
 106   (let (col)
 107     (without-scheduling
 108       (do* ((cols *collectors* (cdr cols))
 109             (this (car cols) (car cols)))
 110           ((null cols))
 111         (if* this
 112            then (setf (car cols) nil)
 113                 (setq col this)
 114                 (return))))
 115     (if*  col
 116        then (setf (collector-next col) 0)
 117             col
 118        else (make-collector
 119              :next 0
 120              :max  100
 121              :data (make-string 100)))))
 122
 123 (defun put-back-collector (col)
 124   (declare (optimize (speed 3) (safety 1)))
 125   (without-scheduling
 126     (do ((cols *collectors* (cdr cols)))
 127         ((null cols)
 128          ; toss it away
 129          nil)
 130       (if* (null (car cols))
 131          then (setf (car cols) col)
 132               (return)))))
 133
 134
 135
 136 (defun grow-and-add (coll ch)
 137   (declare (optimize (speed 3) (safety 1)))
 138   ;; increase the size of the data portion of the collector and then
 139   ;; add the given char at the end
 140   (let* ((odata (collector-data coll))
 141          (ndata (make-string (* 2 (length odata)))))
 142     (dotimes (i (length odata))
 143       (setf (schar ndata i) (schar odata i)))
 144     (setf (collector-data coll) ndata)
 145     (setf (collector-max coll) (length ndata))
 146     (let ((next (collector-next coll)))
 147       (setf (schar ndata next) ch)
 148       (setf (collector-next coll) (1+ next)))))
 149
 150
 151
 152
 153
 154
 155
 156 ;; character characteristics
 157 (defconstant char-tagcharacter   1) ; valid char for a tag
 158 (defconstant char-attribnamechar 2) ; valid char for an attribute name
 159 (defconstant char-attribundelimattribvalue 4) ; valid for undelimited value
 160 (defconstant char-spacechar 8)
 161
 162 (defparameter *characteristics*
 163     ;; array of bits describing character characteristics
 164     (let ((arr (make-array 128 :initial-element 0)))
 165       (declare (optimize (speed 3) (safety 1)))
 166       (macrolet ((with-range ((var from to) &rest body)
 167                    `(do ((,var (char-code ,from) (1+ ,var))
 168                          (mmax  (char-code ,to)))
 169                         ((> ,var mmax))
 170                       ,@body))
 171
 172                  (addit (index charistic)
 173                    `(setf (svref arr ,index)
 174                       (logior (svref arr ,index)
 175                               ,charistic)))
 176                  )
 177
 178         (with-range (i #\A #\Z)
 179           (addit i (+ char-tagcharacter
 180                       char-attribnamechar
 181                       char-attribundelimattribvalue)))
 182
 183         (with-range (i #\a #\z)
 184           (addit i (+ char-tagcharacter
 185                       char-attribnamechar
 186                       char-attribundelimattribvalue)))
 187
 188         (with-range (i #\0 #\9)
 189           (addit i (+ char-tagcharacter
 190                       char-attribnamechar
 191                       char-attribundelimattribvalue)))
 192
 193         ;; let colon be legal tag character
 194         (addit (char-code #\:) (+ char-attribnamechar
 195                                   char-tagcharacter))
 196
 197         ;; NY times special tags have _
 198         (addit (char-code #\_) (+ char-attribnamechar
 199                                   char-tagcharacter))
 200
 201         ; now the unusual cases
 202         (addit (char-code #\-) (+ char-attribnamechar
 203                                   char-attribundelimattribvalue))
 204         (addit (char-code #\.) (+ char-attribnamechar
 205                                   char-attribundelimattribvalue))
 206
 207         ;; adding all typeable chars except for whitespace and >
 208         (addit (char-code #\:) char-attribundelimattribvalue)
 209         (addit (char-code #\@) char-attribundelimattribvalue)
 210         (addit (char-code #\/) char-attribundelimattribvalue)
 211         (addit (char-code #\!) char-attribundelimattribvalue)
 212         (addit (char-code #\#) char-attribundelimattribvalue)
 213         (addit (char-code #\$) char-attribundelimattribvalue)
 214         (addit (char-code #\%) char-attribundelimattribvalue)
 215         (addit (char-code #\^) char-attribundelimattribvalue)
 216         (addit (char-code #\&) char-attribundelimattribvalue)
 217         (addit (char-code #\() char-attribundelimattribvalue)
 218         (addit (char-code #\)) char-attribundelimattribvalue)
 219         (addit (char-code #\_) char-attribundelimattribvalue)
 220         (addit (char-code #\=) char-attribundelimattribvalue)
 221         (addit (char-code #\+) char-attribundelimattribvalue)
 222         (addit (char-code #\\) char-attribundelimattribvalue)
 223         (addit (char-code #\|) char-attribundelimattribvalue)
 224         (addit (char-code #\{) char-attribundelimattribvalue)
 225         (addit (char-code #\}) char-attribundelimattribvalue)
 226         (addit (char-code #\[) char-attribundelimattribvalue)
 227         (addit (char-code #\]) char-attribundelimattribvalue)
 228         (addit (char-code #\;) char-attribundelimattribvalue)
 229         (addit (char-code #\') char-attribundelimattribvalue)
 230         (addit (char-code #\") char-attribundelimattribvalue)
 231         (addit (char-code #\,) char-attribundelimattribvalue)
 232         (addit (char-code #\<) char-attribundelimattribvalue)
 233         (addit (char-code #\?) char-attribundelimattribvalue)
 234
 235         ; i'm not sure what can be in a tag name but we know that
 236         ; ! and - must be there since it's used in comments
 237
 238         (addit (char-code #\-) char-tagcharacter)
 239         (addit (char-code #\!) char-tagcharacter)
 240
 241         ; spaces
 242         (addit (char-code #\space) char-spacechar)
 243         (addit (char-code #\tab) char-spacechar)
 244         (addit (char-code #\return) char-spacechar)
 245         (addit (char-code #\linefeed) char-spacechar)
 246
 247         )
 248
 249
 250
 251       arr))
 252
 253
 254 (defun char-characteristic (char bit)
 255   (declare (optimize (speed 3) (safety 1)))
 256   ;; return true if the given char has the given bit set in
 257   ;; the characteristic array
 258   (let ((code (char-code char)))
 259     (if* (<= 0 code 127)
 260        then ; in range
 261             (not (zerop (logand (svref *characteristics* code) bit))))))
 262
 263
 264 (defvar *html-entity-to-code*
 265     (let ((table (make-hash-table :test #'equal)))
 266       (dolist (ent '(("nbsp" . 160)
 267                      ("iexcl" . 161)
 268                      ("cent" . 162)
 269                      ("pound" . 163)
 270                      ("curren" . 164)
 271                      ("yen" . 165)
 272                      ("brvbar" . 166)
 273                      ("sect" . 167)
 274                      ("uml" . 168)
 275                      ("copy" . 169)
 276                      ("ordf" . 170)
 277                      ("laquo" . 171)
 278                      ("not" . 172)
 279                      ("shy" . 173)
 280                      ("reg" . 174)
 281                      ("macr" . 175)
 282                      ("deg" . 176)
 283                      ("plusmn" . 177)
 284                      ("sup2" . 178)
 285                      ("sup3" . 179)
 286                      ("acute" . 180)
 287                      ("micro" . 181)
 288                      ("para" . 182)
 289                      ("middot" . 183)
 290                      ("cedil" . 184)
 291                      ("sup1" . 185)
 292                      ("ordm" . 186)
 293                      ("raquo" . 187)
 294                      ("frac14" . 188)
 295                      ("frac12" . 189)
 296                      ("frac34" . 190)
 297                      ("iquest" . 191)
 298                      ("Agrave" . 192)
 299                      ("Aacute" . 193)
 300                      ("Acirc" . 194)
 301                      ("Atilde" . 195)
 302                      ("Auml" . 196)
 303                      ("Aring" . 197)
 304                      ("AElig" . 198)
 305                      ("Ccedil" . 199)
 306                      ("Egrave" . 200)
 307                      ("Eacute" . 201)
 308                      ("Ecirc" . 202)
 309                      ("Euml" . 203)
 310                      ("Igrave" . 204)
 311                      ("Iacute" . 205)
 312                      ("Icirc" . 206)
 313                      ("Iuml" . 207)
 314                      ("ETH" . 208)
 315                      ("Ntilde" . 209)
 316                      ("Ograve" . 210)
 317                      ("Oacute" . 211)
 318                      ("Ocirc" . 212)
 319                      ("Otilde" . 213)
 320                      ("Ouml" . 214)
 321                      ("times" . 215)
 322                      ("Oslash" . 216)
 323                      ("Ugrave" . 217)
 324                      ("Uacute" . 218)
 325                      ("Ucirc" . 219)
 326                      ("Uuml" . 220)
 327                      ("Yacute" . 221)
 328                      ("THORN" . 222)
 329                      ("szlig" . 223)
 330                      ("agrave" . 224)
 331                      ("aacute" . 225)
 332                      ("acirc" . 226)
 333                      ("atilde" . 227)
 334                      ("auml" . 228)
 335                      ("aring" . 229)
 336                      ("aelig" . 230)
 337                      ("ccedil" . 231)
 338                      ("egrave" . 232)
 339                      ("eacute" . 233)
 340                      ("ecirc" . 234)
 341                      ("euml" . 235)
 342                      ("igrave" . 236)
 343                      ("iacute" . 237)
 344                      ("icirc" . 238)
 345                      ("iuml" . 239)
 346                      ("eth" . 240)
 347                      ("ntilde" . 241)
 348                      ("ograve" . 242)
 349                      ("oacute" . 243)
 350                      ("ocirc" . 244)
 351                      ("otilde" . 245)
 352                      ("ouml" . 246)
 353                      ("divide" . 247)
 354                      ("oslash" . 248)
 355                      ("ugrave" . 249)
 356                      ("uacute" . 250)
 357                      ("ucirc" . 251)
 358                      ("uuml" . 252)
 359                      ("yacute" . 253)
 360                      ("thorn" . 254)
 361                      ("yuml" . 255)
 362                      ("fnof" . 402)
 363                      ("Alpha" . 913)
 364                      ("Beta" . 914)
 365                      ("Gamma" . 915)
 366                      ("Delta" . 916)
 367                      ("Epsilon" . 917)
 368                      ("Zeta" . 918)
 369                      ("Eta" . 919)
 370                      ("Theta" . 920)
 371                      ("Iota" . 921)
 372                      ("Kappa" . 922)
 373                      ("Lambda" . 923)
 374                      ("Mu" . 924)
 375                      ("Nu" . 925)
 376                      ("Xi" . 926)
 377                      ("Omicron" . 927)
 378                      ("Pi" . 928)
 379                      ("Rho" . 929)
 380                      ("Sigma" . 931)
 381                      ("Tau" . 932)
 382                      ("Upsilon" . 933)
 383                      ("Phi" . 934)
 384                      ("Chi" . 935)
 385                      ("Psi" . 936)
 386                      ("Omega" . 937)
 387                      ("alpha" . 945)
 388                      ("beta" . 946)
 389                      ("gamma" . 947)
 390                      ("delta" . 948)
 391                      ("epsilon" . 949)
 392                      ("zeta" . 950)
 393                      ("eta" . 951)
 394                      ("theta" . 952)
 395                      ("iota" . 953)
 396                      ("kappa" . 954)
 397                      ("lambda" . 955)
 398                      ("mu" . 956)
 399                      ("nu" . 957)
 400                      ("xi" . 958)
 401                      ("omicron" . 959)
 402                      ("pi" . 960)
 403                      ("rho" . 961)
 404                      ("sigmaf" . 962)
 405                      ("sigma" . 963)
 406                      ("tau" . 964)
 407                      ("upsilon" . 965)
 408                      ("phi" . 966)
 409                      ("chi" . 967)
 410                      ("psi" . 968)
 411                      ("omega" . 969)
 412                      ("thetasym" . 977)
 413                      ("upsih" . 978)
 414                      ("piv" . 982)
 415                      ("bull" . 8226)
 416                      ("hellip" . 8230)
 417                      ("prime" . 8242)
 418                      ("Prime" . 8243)
 419                      ("oline" . 8254)
 420                      ("frasl" . 8260)
 421                      ("weierp" . 8472)
 422                      ("image" . 8465)
 423                      ("real" . 8476)
 424                      ("trade" . 8482)
 425                      ("alefsym" . 8501)
 426                      ("larr" . 8592)
 427                      ("uarr" . 8593)
 428                      ("rarr" . 8594)
 429                      ("darr" . 8595)
 430                      ("harr" . 8596)
 431                      ("crarr" . 8629)
 432                      ("lArr" . 8656)
 433                      ("uArr" . 8657)
 434                      ("rArr" . 8658)
 435                      ("dArr" . 8659)
 436                      ("hArr" . 8660)
 437                      ("forall" . 8704)
 438                      ("part" . 8706)
 439                      ("exist" . 8707)
 440                      ("empty" . 8709)
 441                      ("nabla" . 8711)
 442                      ("isin" . 8712)
 443                      ("notin" . 8713)
 444                      ("ni" . 8715)
 445                      ("prod" . 8719)
 446                      ("sum" . 8721)
 447                      ("minus" . 8722)
 448                      ("lowast" . 8727)
 449                      ("radic" . 8730)
 450                      ("prop" . 8733)
 451                      ("infin" . 8734)
 452                      ("ang" . 8736)
 453                      ("and" . 8743)
 454                      ("or" . 8744)
 455                      ("cap" . 8745)
 456                      ("cup" . 8746)
 457                      ("int" . 8747)
 458                      ("there4" . 8756)
 459                      ("sim" . 8764)
 460                      ("cong" . 8773)
 461                      ("asymp" . 8776)
 462                      ("ne" . 8800)
 463                      ("equiv" . 8801)
 464                      ("le" . 8804)
 465                      ("ge" . 8805)
 466                      ("sub" . 8834)
 467                      ("sup" . 8835)
 468                      ("nsub" . 8836)
 469                      ("sube" . 8838)
 470                      ("supe" . 8839)
 471                      ("oplus" . 8853)
 472                      ("otimes" . 8855)
 473                      ("perp" . 8869)
 474                      ("sdot" . 8901)
 475                      ("lceil" . 8968)
 476                      ("rceil" . 8969)
 477                      ("lfloor" . 8970)
 478                      ("rfloor" . 8971)
 479                      ("lang" . 9001)
 480                      ("rang" . 9002)
 481                      ("loz" . 9674)
 482                      ("spades" . 9824)
 483                      ("clubs" . 9827)
 484                      ("hearts" . 9829)
 485                      ("diams" . 9830)
 486                      ("quot" . 34)
 487                      ("amp" . 38)
 488                      ("lt" . 60)
 489                      ("gt" . 62)
 490                      ("OElig" . 338)
 491                      ("oelig" . 339)
 492                      ("Scaron" . 352)
 493                      ("scaron" . 353)
 494                      ("Yuml" . 376)
 495                      ("circ" . 710)
 496                      ("tilde" . 732)
 497                      ("ensp" . 8194)
 498                      ("emsp" . 8195)
 499                      ("thinsp" . 8201)
 500                      ("zwnj" . 8204)
 501                      ("zwj" . 8205)
 502                      ("lrm" . 8206)
 503                      ("rlm" . 8207)
 504                      ("ndash" . 8211)
 505                      ("mdash" . 8212)
 506                      ("lsquo" . 8216)
 507                      ("rsquo" . 8217)
 508                      ("sbquo" . 8218)
 509                      ("ldquo" . 8220)
 510                      ("rdquo" . 8221)
 511                      ("bdquo" . 8222)
 512                      ("dagger" . 8224)
 513                      ("Dagger" . 8225)
 514                      ("permil" . 8240)
 515                      ("lsaquo" . 8249)
 516                      ("rsaquo" . 8250)
 517                      ("euro" . 8364)
 518                      ))
 519         (setf (gethash (car ent) table) (cdr ent)))
 520       table))
 521
 522
 523
 524 (defstruct tokenbuf
 525   cur ;; next index to use to grab from tokenbuf
 526   max ;; index one beyond last character
 527   data ;; character array
 528   first-pass ;; previously parsed tokens
 529   )
 530
 531 ;; cache of tokenbuf structs
 532 (defparameter *tokenbufs* (list nil nil nil nil))
 533
 534 (defun get-tokenbuf ()
 535   (declare (optimize (speed 3) (safety 1)))
 536   (let (buf)
 537     (without-scheduling
 538       (do* ((bufs *tokenbufs* (cdr bufs))
 539             (this (car bufs) (car bufs)))
 540           ((null bufs))
 541         (if* this
 542            then (setf (car bufs) nil)
 543                 (setq buf this)
 544                 (return))))
 545     (if* buf
 546        then (setf (tokenbuf-cur buf) 0)
 547             (setf (tokenbuf-max buf) 0)
 548             buf
 549        else (make-tokenbuf
 550              :cur 0
 551              :max  0
 552              :data (make-array 1024 :element-type 'character)))))
 553
 554 (defun put-back-tokenbuf (buf)
 555   (declare (optimize (speed 3) (safety 1)))
 556   (without-scheduling
 557     (do ((bufs *tokenbufs* (cdr bufs)))
 558         ((null bufs)
 559          ; toss it away
 560          nil)
 561       (if* (null (car bufs))
 562          then (setf (car bufs) buf)
 563               (return)))))
 564
 565 (defun to-preferred-case (ch)
 566   (if* (eq excl:*current-case-mode* :CASE-INSENSITIVE-UPPER)
 567      then (char-upcase ch)
 568      else (char-downcase ch)))
 569
 570
 571 (defun next-token (stream ignore-strings raw-mode-delimiter
 572                    read-sequence-func tokenbuf parse-entities)
 573   (declare (optimize (speed 3) (safety 1)))
 574   ;; return two values:
 575   ;;    the next token from the stream.
 576   ;;    the kind of token (:pcdata, :start-tag, :end-tag, :eof)
 577   ;;
 578   ;; if read-sequence-func is non-nil,
 579   ;; read-sequence-func is called to fetch the next character
 580   (macrolet ((next-char (stream)
 581                `(let ((cur (tokenbuf-cur tokenbuf))
 582                       (tb (tokenbuf-data tokenbuf)))
 583                   (if* (>= cur (tokenbuf-max tokenbuf))
 584                      then ; fill buffer
 585                           (if* (zerop (setf (tokenbuf-max tokenbuf)
 586                                         (if* read-sequence-func
 587                                            then (funcall read-sequence-func tb stream)
 588                                            else (read-sequence tb stream))))
 589                              then (setq cur nil) ; eof
 590                              else (setq cur 0)))
 591                   (if* cur
 592                      then (prog1 (schar tb cur)
 593                             (setf (tokenbuf-cur tokenbuf) (1+ cur))))))
 594
 595
 596              (un-next-char (stream ch)
 597                `(decf (tokenbuf-cur tokenbuf)))
 598
 599              (clear-coll (coll)
 600                `(setf (collector-next coll) 0))
 601
 602              (add-to-coll (coll ch)
 603                `(let ((.next. (collector-next ,coll)))
 604                   (if* (>= .next. (collector-max ,coll))
 605                      then (grow-and-add ,coll ,ch)
 606                      else (setf (schar (collector-data ,coll) .next.)
 607                             ,ch)
 608                           (setf (collector-next ,coll) (1+ .next.)))))
 609
 610              )
 611
 612     (let ((state (if* raw-mode-delimiter then state-rawdata else state-pcdata))
 613           (coll  (get-collector))
 614           (ch)
 615
 616           (value-delim)
 617
 618           (tag-to-return)
 619           (attribs-to-return)
 620
 621           (end-tag)
 622
 623           (attrib-name)
 624           (attrib-value)
 625
 626           (name-length 0) ;; count only when it could be a comment
 627
 628           (raw-length 0)
 629           (xml-bailout)
 630           )
 631
 632       (loop
 633
 634         (setq ch (next-char stream))
 635         ;;(format t "ch: ~s state: ~s~%" ch state)
 636
 637         (if* (null ch)
 638            then (return) ; eof -- exit loop
 639                 )
 640
 641
 642         (case state
 643           (#.state-pcdata
 644            ; collect everything until we see a <
 645            (if* (eq ch #\<)
 646               then ; if we've collected nothing then get a tag
 647                    (if* (> (collector-next coll) 0)
 648                       then ; have collected something, return this string
 649                            (un-next-char stream ch) ; push back the <
 650                            (return)
 651                       else ; collect a tag
 652                            (setq state state-readtagfirst))
 653             elseif (and parse-entities (eq ch #\&))
 654               then ; reading an entity. entity ends at semicolon
 655                    (let (res (max 10))
 656                      (loop (let ((ch (next-char stream)))
 657                              (if* (null ch)
 658                                 then (error "End of file after & entity marker")
 659                               elseif (eq ch #\;)
 660                                 then (return)
 661                               elseif (zerop (decf max))
 662                                 then (error "No semicolon found after entity starting: &~{~a~}" (nreverse res))
 663                                 else (push ch res))))
 664                      (setq res (nreverse res))
 665                      (if* (eq (car res) #\#)
 666                         then ; decimal entity
 667                              (let ((count 0))
 668                                (dolist (ch (cdr res))
 669                                  (let ((code (char-code ch)))
 670                                    (if* (<= #.(char-code #\0)
 671                                             code
 672                                             #.(char-code #\9))
 673                                       then (setq count
 674                                              (+ (* 10 count)
 675                                                 (- code
 676                                                    #.(char-code #\0))))
 677                                       else (error "non decimal digit after &# - ~s" ch)
 678                                            )))
 679                                (add-to-coll coll (code-char count)))
 680                         else (let ((name (make-array (length res)
 681                                                      :element-type 'character
 682                                                      :initial-contents res)))
 683                                (let ((ch (gethash name *html-entity-to-code*)))
 684                                  (if* ch
 685                                     then (add-to-coll coll (code-char ch))
 686                                     else (error "No such entity as ~s" name))))))
 687
 688               else ; we will check for & here eventually
 689                    (if* (not (eq ch #\return))
 690                       then (add-to-coll coll ch))))
 691
 692           (#.state-readtagfirst
 693            ; starting to read a tag name
 694            (if* (eq #\/ ch)
 695               then ; end tag
 696                    (setq end-tag t)
 697               else (if* (eq #\! ch) ; possible comment
 698                       then (setf xml-bailout t)
 699                            (setq name-length 0))
 700                    (un-next-char stream ch))
 701            (setq state state-readtag))
 702
 703           (#.state-readtag
 704            ;; reading the whole tag name
 705            (if* (char-characteristic ch char-tagcharacter)
 706               then (add-to-coll coll (to-preferred-case ch))
 707                    (incf name-length)
 708                    (if* (and (eq name-length 3)
 709                              (coll-has-comment coll))
 710                       then (clear-coll coll)
 711                            (setq state state-readcomment))
 712
 713               else (setq tag-to-return (compute-tag coll))
 714                    (clear-coll coll)
 715                    (if* (eq ch #\>)
 716                       then (return)     ; we're done
 717                     elseif xml-bailout then
 718                            (un-next-char stream ch)
 719                            (return)
 720                       else (if* (eq tag-to-return :!--)
 721                               then ; a comment
 722                                    (setq state state-readcomment)
 723                               else (un-next-char stream ch)
 724                                    (setq state state-findattribname)))))
 725
 726           (#.state-findattribname
 727            ;; search until we find the start of an attribute name
 728            ;; or the end of the tag
 729            (if* (eq ch #\>)
 730               then ; end of the line
 731                    (return)
 732             elseif (eq ch #\=)
 733               then ; value for previous attribute name
 734                    ; (syntax  "foo = bar" is bogus I think but it's
 735                    ; used some places, here is where we handle this
 736                    (pop attribs-to-return)
 737                    (setq attrib-name (pop attribs-to-return))
 738                    (setq state state-findvalue)
 739             elseif (char-characteristic ch char-attribnamechar)
 740               then (un-next-char stream ch)
 741                    (setq state state-attribname)
 742               else nil ; ignore other things
 743                    ))
 744
 745           (#.state-findvalue
 746            ;; find the start of the value
 747            (if* (char-characteristic ch char-spacechar)
 748               thenret ; keep looking
 749             elseif (eq ch #\>)
 750               then ; no value, set the value to be the
 751                    ; name as a string
 752                    (setq attrib-value
 753                      (string-downcase (string attrib-name)))
 754
 755                    (push attrib-name attribs-to-return)
 756                    (push attrib-value attribs-to-return)
 757                    (un-next-char stream ch)
 758                    (setq state state-findattribname)
 759               else (un-next-char stream ch)
 760                    (setq state state-attribstartvalue)))
 761
 762
 763           (#.state-attribname
 764            ;; collect attribute name
 765
 766            (if* (char-characteristic ch char-attribnamechar)
 767               then (add-to-coll coll (to-preferred-case ch))
 768             elseif (eq #\= ch)
 769               then ; end of attribute name, value is next
 770                    (setq attrib-name (compute-tag coll))
 771                    (clear-coll coll)
 772                    (setq state state-attribstartvalue)
 773               else ; end of attribute name with no value,
 774                    (setq attrib-name (compute-tag coll))
 775                    (clear-coll coll)
 776                    (setq attrib-value
 777                      (string-downcase (string attrib-name)))
 778                    (push attrib-name attribs-to-return)
 779                    (push attrib-value attribs-to-return)
 780                    (un-next-char stream ch)
 781                    (setq state state-findattribname)))
 782
 783           (#.state-attribstartvalue
 784            ;; begin to collect value
 785            (if* (or (eq ch #\")
 786                     (eq ch #\'))
 787               then (setq value-delim ch)
 788                    (setq state state-attribvaluedelim)
 789                    ;; gobble spaces; assume since we've seen a '=' there really is a value
 790             elseif (eq #\space ch) then nil
 791               else (un-next-char stream ch)
 792                    (setq state state-attribvaluenodelim)))
 793
 794           (#.state-attribvaluedelim
 795            (if* (eq ch value-delim)
 796               then (setq attrib-value (compute-coll-string coll))
 797                    (clear-coll coll)
 798                    (push attrib-name attribs-to-return)
 799                    (push attrib-value attribs-to-return)
 800                    (setq state state-findattribname)
 801               else (add-to-coll coll ch)))
 802
 803           (#.state-attribvaluenodelim
 804            ;; an attribute value not delimited by ' or " and thus restricted
 805            ;; in the possible characters
 806            (if* (char-characteristic ch char-attribundelimattribvalue)
 807               then (add-to-coll coll ch)
 808               else (un-next-char stream ch)
 809                    (setq attrib-value (compute-coll-string coll))
 810                    (clear-coll coll)
 811                    (push attrib-name attribs-to-return)
 812                    (push attrib-value attribs-to-return)
 813                    (setq state state-findattribname)))
 814
 815           (#.state-readcomment
 816            ;; a comment ends on the first --, but we'll look for -->
 817            ;; since that's what most people expect
 818            (if* (eq ch #\-)
 819               then (setq state state-readcomment-one)
 820               else (add-to-coll coll ch)))
 821
 822           (#.state-readcomment-one
 823            ;; seen one -, looking for ->
 824
 825            (if* (eq ch #\-)
 826               then (setq state state-readcomment-two)
 827               else ; not a comment end, put back the -'s
 828                    (add-to-coll coll #\-)
 829                    (add-to-coll coll ch)
 830                    (setq state state-readcomment)))
 831
 832           (#.state-readcomment-two
 833            ;; seen two -'s, looking for >
 834
 835            (if* (eq ch #\>)
 836               then ; end of the line
 837                    (return)
 838             elseif (eq ch #\-)
 839               then ; still at two -'s, have to put out first
 840                    (add-to-coll coll #\-)
 841               else ; put out two hypens and back to looking for a hypen
 842                    (add-to-coll coll #\-)
 843                    (add-to-coll coll #\-)
 844                    (setq state state-readcomment)))
 845
 846           (#.state-rawdata
 847            ;; collect everything until we see the delimiter
 848            (if* (eq (to-preferred-case ch) (elt raw-mode-delimiter raw-length))
 849               then
 850                    (incf raw-length)
 851                    (when (= raw-length (length raw-mode-delimiter))
 852                      ;; push the end tag back so it can then be lexed
 853                      ;; but don't do it for xml stuff
 854                      (when (/= (length  raw-mode-delimiter) 1)
 855                        (push :end-tag (tokenbuf-first-pass tokenbuf))
 856                        (if* (equal raw-mode-delimiter "</STYLE>")
 857                           then (push :STYLE (tokenbuf-first-pass tokenbuf))
 858                         elseif (equal raw-mode-delimiter "</style>")
 859                           then (push :style (tokenbuf-first-pass tokenbuf))
 860                         elseif (equal raw-mode-delimiter "</SCRIPT>")
 861                           then (push :SCRIPT (tokenbuf-first-pass tokenbuf))
 862                         elseif (equal raw-mode-delimiter "</script>")
 863                           then (push :script (tokenbuf-first-pass tokenbuf))
 864                           else (error "unexpected raw-mode-delimiter"))
 865                        )
 866                      ;; set state to state-pcdata for next section
 867                      (return))
 868               else
 869                    ;; push partial matches into data string
 870                    (dotimes (i raw-length)
 871                      (add-to-coll coll (elt raw-mode-delimiter i)))
 872                    (setf raw-length 0)
 873                    (add-to-coll coll ch)))
 874
 875           ))
 876
 877
 878       ;; out of the loop.
 879       ;; if we're in certain states then it means we should return a value
 880       ;;
 881       (case state
 882         ((#.state-pcdata #.state-rawdata)
 883          ;; return the buffer as a string
 884          (if* (zerop (collector-next coll))
 885             then (values nil (if (eq state state-pcdata) :eof :pcdata))
 886             else (values (prog1
 887                              (if* (null ignore-strings)
 888                                 then (compute-coll-string coll))
 889                            (put-back-collector coll))
 890                          :pcdata)))
 891
 892         (#.state-readtag
 893          (when (null tag-to-return)
 894            (error "unexpected end of input encountered"))
 895          ;; we've read a tag with no attributes
 896          (put-back-collector coll)
 897          (values tag-to-return
 898                  (if* end-tag
 899                     then :end-tag
 900                     else (if* xml-bailout then :xml else :start-tag))
 901                  ))
 902
 903         (#.state-findattribname
 904          ;; returning a tag with possible attributes
 905          (put-back-collector coll)
 906          (if* end-tag
 907             then ; ignore any attributes
 908                  (values tag-to-return :end-tag)
 909           elseif attribs-to-return
 910             then (values (cons tag-to-return
 911                                (nreverse attribs-to-return))
 912                          :start-tag)
 913             else (values tag-to-return :start-tag)))
 914
 915         (#.state-readcomment-two
 916          ;; returning a comment
 917          (values (prog1 (if* (null ignore-strings)
 918                            then (compute-coll-string coll))
 919                    (put-back-collector coll))
 920                  :comment))
 921
 922         (t
 923          (if* (null ch) then (error "unexpected end of input encountered")
 924             else (error "internal error, can't be here in state ~d" state)))))))
 925
 926
 927 (defvar *kwd-package* (find-package :keyword))
 928
 929 (defun compute-tag (coll)
 930   (declare (optimize (speed 3) (safety 1)))
 931   ;; compute the symbol named by what's in the collector
 932   (excl::intern* (collector-data coll) (collector-next coll) *kwd-package*))
 933
 934
 935
 936 (defun compute-coll-string (coll)
 937   (declare (optimize (speed 3) (safety 1)))
 938   ;; return the string that's in the collection
 939   (let ((str (make-string (collector-next coll)))
 940         (from (collector-data coll)))
 941     (dotimes (i (collector-next coll))
 942       (setf (schar str i) (schar from i)))
 943
 944     str))
 945
 946 (defun coll-has-comment (coll)
 947   (declare (optimize (speed 3) (safety 1)))
 948   ;; true if the collector has exactly "!--" in it
 949   (and (eq 3 (collector-next coll))
 950        (let ((data (collector-data coll)))
 951          (and (eq #\! (schar data 0))
 952               (eq #\- (schar data 1))
 953               (eq #\- (schar data 2))))))
 954
 955
 956 ;;;;;;;;;;; quick and dirty parse
 957
 958 ; the elements with no body and thus no end tag
 959 (dolist (opt '(:area :base :basefont :bgsound :br :button :col
 960                ;;:colgroup - no, this is an element with contents
 961                :embed :hr :img :frame
 962                :input :isindex :keygen :link :meta
 963                :plaintext :spacer :wbr))
 964   (setf (tag-no-end opt) t))
 965
 966 (defvar *in-line* '(:tt :i :b :big :small :em :strong :dfn :code :samp :kbd
 967                     :var :cite :abbr :acronym :a :img :object :br :map
 968                     :q :sub :sup :span :bdo :input :select :textarea :label :button :font))
 969
 970 (defvar *ch-format* '(:i :b :tt :big :small :strike :s :u
 971                       :em :strong :font))
 972
 973 (defvar *known-tags* '(:!doctype :a :acronym :address :applet :area :b :base :basefont
 974                        :bdo :bgsound :big :blink :blockquote :body :br :button :caption
 975                        :center :cite :code :col :colgroup :comment :dd :del :dfn :dir
 976                        :div :dl :dt :em :embed :fieldset :font :form :frame :frameset
 977                        :h1 :h2 :h3 :h4 :h5 :h6 :head :hr :html :i :iframe :img :input
 978                        :ins :isindex :kbd :label :layer :legend :li :link :listing :map
 979                        :marquee :menu :meta :multicol :nobr :noframes :noscript :object
 980                        :ol :option :p :param :plaintext :pre :q :samp :script :select
 981                        :small :spacer :span :s :strike :strong :style :sub :sup :table
 982                        :tbody :td :textarea :tfoot :th :thead :title :tr :tt :u :ul :var
 983                        :wbr :xmp))
 984
 985 ; the elements whose start tag can end a previous tag
 986
 987 (setf (tag-auto-close :tr) '(:tr :td :th :colgroup))
 988 (setf (tag-auto-close-stop :tr) '(:table))
 989
 990 (setf (tag-auto-close :td) '(:td :th))
 991 (setf (tag-auto-close-stop :td) '(:table))
 992
 993 (setf (tag-auto-close :th) '(:td :th))
 994 (setf (tag-auto-close-stop :th) '(:table))
 995
 996 (setf (tag-auto-close :dt) '(:dt :dd))
 997 (setf (tag-auto-close-stop :dt) '(:dl))
 998
 999 (setf (tag-auto-close :li) '(:li))
1000 (setf (tag-auto-close-stop :li) '(:ul :ol))
1001
1002 ;; new stuff to close off tags with optional close tags
1003 (setf (tag-auto-close :address) '(:head :p))
1004 (setf (tag-auto-close :blockquote) '(:head :p))
1005 (setf (tag-auto-close :body) '(:body :frameset :head))
1006
1007 (setf (tag-auto-close :dd) '(:dd :dt))
1008 (setf (tag-auto-close-stop :dd) '(:dl))
1009
1010 (setf (tag-auto-close :dl) '(:head :p))
1011 (setf (tag-auto-close :div) '(:head :p))
1012 (setf (tag-auto-close :fieldset) '(:head :p))
1013 (setf (tag-auto-close :form) '(:head :p))
1014 (setf (tag-auto-close :frameset) '(:body :frameset :head))
1015 (setf (tag-auto-close :hr) '(:head :p))
1016 (setf (tag-auto-close :h1) '(:head :p))
1017 (setf (tag-auto-close :h2) '(:head :p))
1018 (setf (tag-auto-close :h3) '(:head :p))
1019 (setf (tag-auto-close :h4) '(:head :p))
1020 (setf (tag-auto-close :h5) '(:head :p))
1021 (setf (tag-auto-close :h6) '(:head :p))
1022 (setf (tag-auto-close :noscript) '(:head :p))
1023 (setf (tag-auto-close :ol) '(:head :p))
1024
1025 (setf (tag-auto-close :option) '(:option))
1026 (setf (tag-auto-close-stop :option) '(:select))
1027
1028 (setf (tag-auto-close :p) '(:head :p))
1029
1030 (setf (tag-auto-close :pre) '(:head :p))
1031 (setf (tag-auto-close :table) '(:head :p))
1032
1033 (setf (tag-auto-close :tbody) '(:colgroup :tfoot :tbody :thead))
1034 (setf (tag-auto-close-stop :tbody) '(:table))
1035
1036 (setf (tag-auto-close :tfoot) '(:colgroup :tfoot :tbody :thead))
1037 (setf (tag-auto-close-stop :tfoot) '(:table))
1038
1039 (setf (tag-auto-close :thead) '(:colgroup :tfoot :tbody :thead))
1040 (setf (tag-auto-close-stop :thead) '(:table))
1041
1042 (setf (tag-auto-close :ul) '(:head :p))
1043
1044 (setf (tag-no-pcdata :table) t)
1045 (setf (tag-no-pcdata :tr) t)
1046
1047
1048 (defmethod parse-html ((p stream) &key callback-only callbacks collect-rogue-tags
1049                                        no-body-tags
1050                                        parse-entities)
1051   (declare (optimize (speed 3) (safety 1)))
1052   (phtml-internal p nil callback-only callbacks collect-rogue-tags
1053                   no-body-tags parse-entities))
1054
1055 (defmacro tag-callback (tag)
1056   `(rest (assoc ,tag callbacks)))
1057
1058 (defun phtml-internal (p read-sequence-func callback-only
1059                        callbacks collect-rogue-tags
1060                        no-body-tags
1061                        parse-entities)
1062   (declare (optimize (speed 3) (safety 1)))
1063   (let ((raw-mode-delimiter nil)
1064         (pending nil)
1065         (current-tag :start-parse)
1066         (last-tag :start-parse)
1067         (current-callback-tags nil)
1068         (pending-ch-format nil)
1069         (closed-pending-ch-format nil)
1070         (new-opens nil)
1071         (tokenbuf (get-tokenbuf))
1072         (guts)
1073         (rogue-tags)
1074         )
1075     (labels ((close-off-tags (name stop-at collect-rogues once-only)
1076                ;; close off an open 'name' tag, but search no further
1077                ;; than a 'stop-at' tag.
1078                #+ignore (format t "close off name ~s, stop at ~s, ct ~s~%"
1079                        name stop-at current-tag)
1080                (if* (member (tag-name current-tag) name :test #'eq)
1081                   then ;; close current tag(s)
1082                        (loop
1083                          (when (and collect-rogues
1084                                     (not (member (tag-name current-tag)
1085                                                  *known-tags*)))
1086                            (push (tag-name current-tag) rogue-tags))
1087                          (close-current-tag)
1088                          (if* (or once-only
1089                                   (member (tag-name current-tag)
1090                                           *ch-format*)
1091                                   (not (member
1092                                         (tag-name current-tag) name :test #'eq)))
1093                             then (return)))
1094                 elseif (member (tag-name current-tag) stop-at :test #'eq)
1095                   then nil
1096                   else ; search if there is a tag to close
1097                        (dolist (ent pending)
1098                          (if* (member (tag-name (car ent)) name :test #'eq)
1099                             then ; found one to close
1100                                  (loop
1101                                    (when (and collect-rogues
1102                                               (not (member (tag-name current-tag)
1103                                                            *known-tags*)))
1104                                      (push (tag-name current-tag) rogue-tags))
1105                                    (close-current-tag)
1106                                    (if* (member (tag-name current-tag) name
1107                                                 :test #'eq)
1108                                       then (close-current-tag)
1109                                            (return)))
1110                                  (return)
1111                           elseif (member (tag-name (car ent)) stop-at
1112                                          :test #'eq)
1113                             then (return) ;; do nothing
1114                                  ))))
1115
1116              (close-current-tag ()
1117                ;; close off the current tag and open the pending tag
1118                (when (member (tag-name current-tag) *ch-format* :test #'eq)
1119                  (push current-tag closed-pending-ch-format)
1120                  )
1121                (let (element)
1122                  (if* (tag-no-pcdata (tag-name current-tag))
1123                     then (setq element `(,current-tag
1124                                          ,@(strip-rev-pcdata guts)))
1125                     else (setq element `(,current-tag ,@(nreverse guts))))
1126                  (let ((callback (tag-callback (tag-name current-tag))))
1127                    (when callback
1128                      (setf current-callback-tags (rest current-callback-tags))
1129                      (funcall callback element)))
1130                  (let* ((prev (pop pending)))
1131                    (setq current-tag (car prev)
1132                          guts (cdr prev))
1133                    (push element guts))))
1134
1135              (save-state ()
1136                ;; push the current tag state since we're starting:
1137                ;; a new open tag
1138                (push (cons current-tag guts) pending)
1139                #+ignore (format t "state saved, pending ~s~%" pending)
1140                )
1141
1142
1143              (strip-rev-pcdata (stuff)
1144                ;; reverse the list stuff, omitting all the strings
1145                (let (res)
1146                  (dolist (st stuff)
1147                    (if* (not (stringp st)) then (push st res)))
1148                  res))
1149              (check-in-line (check-tag)
1150                (setf new-opens nil)
1151                (let (val kind (i 0)
1152                      (length (length (tokenbuf-first-pass tokenbuf))))
1153                  (loop
1154                    (if* (< i length) then
1155                            (setf val (nth i (tokenbuf-first-pass tokenbuf)))
1156                            (setf kind (nth (+ i 1) (tokenbuf-first-pass tokenbuf)))
1157                            (setf i (+ i 2))
1158                            (if* (= i length) then (setf (tokenbuf-first-pass tokenbuf)
1159                                                     (nreverse (tokenbuf-first-pass tokenbuf))))
1160                       else
1161                            (multiple-value-setq (val kind)
1162                              (get-next-token t))
1163                            (push val (tokenbuf-first-pass tokenbuf))
1164                            (push kind (tokenbuf-first-pass tokenbuf))
1165                            )
1166                    (when (eq kind :eof)
1167                      (if* (= i length) then
1168                              (setf (tokenbuf-first-pass tokenbuf)
1169                                (nreverse (tokenbuf-first-pass tokenbuf))))
1170                      (return))
1171                    (when (and (eq val check-tag) (eq kind :end-tag))
1172                      (if* (= i length) then
1173                              (setf (tokenbuf-first-pass tokenbuf)
1174                                (nreverse (tokenbuf-first-pass tokenbuf))))
1175                      (return))
1176                    (when (member val *ch-format* :test #'eq)
1177                      (if* (eq kind :start-tag) then (push val new-opens)
1178                       elseif (member val new-opens :test #'eq) then
1179                              (setf new-opens (remove val new-opens :count 1))
1180                         else (close-off-tags (list val) nil nil nil)
1181                              )))))
1182
1183              (get-next-token (force)
1184                (if* (or force (null (tokenbuf-first-pass tokenbuf))) then
1185                        (multiple-value-bind (val kind)
1186                            (next-token p nil raw-mode-delimiter read-sequence-func
1187                                        tokenbuf parse-entities)
1188                          (values val kind))
1189                   else
1190                        (let ((val (first (tokenbuf-first-pass tokenbuf)))
1191                              (kind (second (tokenbuf-first-pass tokenbuf))))
1192                          (setf (tokenbuf-first-pass tokenbuf)
1193                            (rest (rest (tokenbuf-first-pass tokenbuf))))
1194                          (values val kind))))
1195              )
1196       (loop
1197         (multiple-value-bind (val kind)
1198             (get-next-token nil)
1199           #+ignore (format t "val: ~s kind: ~s  last-tag ~s pending ~s~%" val kind
1200                   last-tag pending)
1201           (case kind
1202             (:pcdata
1203              (when (or (and callback-only current-callback-tags)
1204                        (not callback-only))
1205                (if* (member last-tag *in-line*)
1206                   then
1207                        (push val guts)
1208                   else
1209                        (when (dotimes (i (length val) nil)
1210                                (when (not (char-characteristic (elt val i)
1211                                                                char-spacechar))
1212                                  (return t)))
1213                          (push val guts))))
1214              (when (and (= (length raw-mode-delimiter) 1) ;; xml tag...
1215                         (or (and callback-only current-callback-tags)
1216                             (not callback-only)))
1217                (close-off-tags (list last-tag) nil nil t))
1218              (setf raw-mode-delimiter nil)
1219              )
1220
1221             (:xml
1222              (setf last-tag val)
1223              (setf raw-mode-delimiter ">")
1224              (let* ((name (tag-name val)))
1225                (when (and callback-only (tag-callback name))
1226                  (push name current-callback-tags))
1227                (save-state)
1228                (setq current-tag val)
1229                (setq guts nil)
1230                ))
1231
1232             (:start-tag
1233              (setf last-tag val)
1234              (if* (or (eq last-tag :style)
1235                       (and (listp last-tag) (eq (first last-tag) :style)))
1236                 then
1237                      (setf raw-mode-delimiter
1238                        (if* (eq excl:*current-case-mode* :CASE-INSENSITIVE-UPPER)
1239                           then "</STYLE>"
1240                           else "</style>"))
1241               elseif (or (eq last-tag :script)
1242                          (and (listp last-tag) (eq (first last-tag) :script)))
1243                 then
1244                      (setf raw-mode-delimiter
1245                        (if* (eq excl:*current-case-mode* :CASE-INSENSITIVE-UPPER)
1246                           then "</SCRIPT>"
1247                           else "</script>")))
1248              ; maybe this is an end tag too
1249              (let* ((name (tag-name val))
1250                     (auto-close (tag-auto-close name))
1251                     (auto-close-stop nil)
1252                     (no-end (or (tag-no-end name) (member name no-body-tags))))
1253                (when (and callback-only (tag-callback name))
1254                  (push name current-callback-tags))
1255                (when (or (and callback-only current-callback-tags)
1256                          (not callback-only))
1257                  (if* auto-close
1258                     then (setq auto-close-stop (tag-auto-close-stop name))
1259                          (close-off-tags auto-close auto-close-stop nil nil))
1260                  (when (and pending-ch-format (not no-end))
1261                    (if* (member name *ch-format* :test #'eq) then nil
1262                     elseif (member name *in-line* :test #'eq) then
1263                            ;; close off only tags that are within *in-line* block
1264                            (check-in-line name)
1265                       else ;; close ALL pending char tags and then reopen
1266                            (dolist (this-tag (reverse pending-ch-format))
1267                              (close-off-tags (list (if (listp this-tag) (first this-tag) this-tag)) nil nil nil))
1268                            ))
1269                  (if* no-end
1270                     then                ; this is a singleton tag
1271                          (let ((callback (tag-callback (tag-name (if* (atom val)
1272                                                                     then val
1273                                                                     else (first val))))))
1274                            (when callback
1275                              (funcall callback (if* (atom val)
1276                                                   then val
1277                                                   else (list val)))))
1278                          (push (if* (atom val)
1279                                   then val
1280                                   else (list val))
1281                                guts)
1282                     else (save-state)
1283                          (setq current-tag val)
1284                          (setq guts nil))
1285                  (if* (member name *ch-format* :test #'eq)
1286                     then (push val pending-ch-format)
1287                     else (when (not
1288                                 (or (eq last-tag :style)
1289                                     (and (listp last-tag) (eq (first last-tag) :style))
1290                                     (eq last-tag :script)
1291                                     (and (listp last-tag) (eq (first last-tag) :script))))
1292                            (dolist (tmp (reverse closed-pending-ch-format))
1293                              (save-state)
1294                              (setf current-tag tmp)
1295                              (setf guts nil)))
1296                          )
1297                  (when (not
1298                         (or (eq last-tag :style)
1299                             (and (listp last-tag) (eq (first last-tag) :style))
1300                             (eq last-tag :script)
1301                             (and (listp last-tag) (eq (first last-tag) :script))))
1302                    (setf closed-pending-ch-format nil))
1303                  )))
1304
1305             (:end-tag
1306              (setf raw-mode-delimiter nil)
1307              (when (or (and callback-only current-callback-tags)
1308                        (not callback-only))
1309                (close-off-tags (list val) nil nil t)
1310                (when (member val *ch-format* :test #'eq)
1311                  (setf pending-ch-format
1312                    (remove val pending-ch-format :count 1
1313                            :test #'(lambda (x y) (eq x (if (listp y) (first y) y)))))
1314                  (setf closed-pending-ch-format
1315                    (remove val closed-pending-ch-format :count 1
1316                            :test #'(lambda (x y) (eq x (if (listp y) (first y) y)))))
1317                  )
1318                (dolist (tmp (reverse closed-pending-ch-format))
1319                  (save-state)
1320                  (setf current-tag tmp)
1321                  (setf guts nil))
1322                (setf closed-pending-ch-format nil)
1323                ))
1324
1325             (:comment
1326              (setf raw-mode-delimiter nil)
1327              (when (or (and callback-only current-callback-tags)
1328                        (not callback-only))
1329                (push `(:comment ,val) guts)))
1330
1331             (:eof
1332              (setf raw-mode-delimiter nil)
1333              ;; close off all tags
1334              (when (or (and callback-only current-callback-tags)
1335                        (not callback-only))
1336                (close-off-tags '(:start-parse) nil collect-rogue-tags nil))
1337              (put-back-tokenbuf tokenbuf)
1338              (if collect-rogue-tags
1339                  (return (values (cdar guts) rogue-tags))
1340                (return (cdar guts))))))))))
1341
1342
1343
1344 (defmethod parse-html (file &key callback-only callbacks collect-rogue-tags
1345                                  no-body-tags parse-entities)
1346   (declare (optimize (speed 3) (safety 1)))
1347   (with-open-file (p file :direction :input)
1348     (parse-html p :callback-only callback-only :callbacks callbacks
1349                 :collect-rogue-tags collect-rogue-tags
1350                 :no-body-tags no-body-tags
1351                 :parse-entities parse-entities
1352                 )))
1353
1354
1355 (defmethod parse-html ((str string) &key callback-only callbacks collect-rogue-tags
1356                                          no-body-tags parse-entities)
1357   (declare (optimize (speed 3) (safety 1)))
1358   (parse-html (make-string-input-stream str)
1359               :callback-only callback-only :callbacks callbacks
1360               :collect-rogue-tags collect-rogue-tags
1361               :no-body-tags no-body-tags
1362                 :parse-entities parse-entities
1363               ))
1364
1365
1366
1367
1368
1369
1370
1371
1372
1373 ;;;;;;;;;;;; test
1374
1375 ;;;(defun doit (ignore-data)
1376 ;;;  (with-open-file (p "readme.htm")
1377 ;;;    (loop
1378 ;;;      (multiple-value-bind (val kind) (next-token p ignore-data)
1379 ;;;      ;(format t "~s -> ~s~%" kind val)
1380 ;;;
1381 ;;;     (if* (eq kind :eof) then (return))))))
1382 ;;;
1383 ;;;(defun pdoit (&optional (file "testa.html"))
1384 ;;;  (with-open-file (p file)
1385 ;;;    (parse-html p)))
1386 ;;;
1387 ;;;
1388 ;;;;; requires http client module to work
1389 ;;;(defun getparse (host path)
1390 ;;;  (parse-html (httpr-body
1391 ;;;       (parse-response
1392 ;;;        (simple-get host path)))))
1393
1394 (provide :phtml)