Старая версия
Здесь находится настоящий сайт
Разбираем комплексный элемент
Самый сложный элемент. Гораздо сложнее комментариев. У нас есть открывающие и закрывающие теги, атрибуты и их значения, а ко всему прочему, элементы ещё могут быть вложенными.
У него даже конструктор сложный 
(defun make-element-node (tag attrs children)
"Tag and list of name-value pairs"
(let ((el (make-instance 'element-node :tag tag :children children)))
(element-set-all-attrs el attrs)
el))
Чтобы это работало, нужно добавить функцию в dom.lisp:
;; Set all attrs at once
(defun element-set-all-attrs (el vals)
"Set all attrs at once. Vals is name-value pair list."
(let ((attrs (element-node-attrs el)))
(mapc #'(lambda (nv)
(setf (gethash (car nv) attrs) (cdr nv))) vals)))
Ещё нам понадобится много маленьких парсеров, начиная с парсера имени тега.
(parse-tagname ()
"Parse tag name"
(let (ch)
(with-output-to-string (s)
(matchit $[@(tag-text ch) !(write-char ch s)]))))
Полезная штука — пропуск пробелов, табуляций и пр. Успешна всегда.
(skip-whitespace ()
(let (ch)
(matchit $[@(whitespace ch)])
t))
Значения атрибутов могут быть заключены или в двойные или в одинарные кавычки, парсер таким образом должен запомнить с кавычки какого типа началось значение и работать до точно такой же закрывающей кавычки.
(parse-value (quo)
(let (ch)
(with-output-to-string (s)
(matchit $[@(any-text ch) !(char/= ch quo) !(write-char ch s)]))))
(parse-quoted-value ()
"Parse quoted value"
(let (quo (oldindex index))
(or (matchit
[ {[#\' !(setf quo #\')] [#\" !(setf quo #\")]}
!(parse-value quo)])
(progn (setf index oldindex) nil))))
С такими помощниками сделать парсер одного атрибута легко: сначала выделим имя (не пустое), затем знак = и значение атрибута в каких-нибудь кавычках. На выходе будет пара (имя . значение).
(parse-attr ()
"name=value"
(let (name value (oldindex index))
(if
(matchit
[ !(setf name (parse-tagname))
!(not (zerop (length name)))
#\= !(setf value (parse-quoted-value))])
(cons name value)
(progn (setf index oldindex) nil))))
Распознанные атрибуты заталкиваем в список. Порядок будет обратным.
(parse-attrs ()
"Parse attributes"
(let (attrs)
(matchit
$[ !(skip-whitespace)
!(setf attr (parse-attr))
!(push attr attrs)])
attrs))
Закрывающий тег так же требует внимания.
(parse-closing-tag (tagname)
"Parse </tagname>"
(let ((oldindex index))
(or
(matchit
[#\< #\/ !(string= (parse-tagname) tagname) #\>])
(progn (setf index oldindex) nil))))
Эскиз парсера элемента:
(parse-element ()
"<tagname $[attr=value]> ??? </tagname>"
(let ((oldindex index)
ch tagname attrs)
(or (matchit
[!(setf tagname (parse-tagname))
{!(setf attrs (parse-attrs)) !T}
#\>
!(parse-closing-tag tagname)
!(make-element-node tagname attrs nil)])
(progn (setf index oldindex) nil))))
Проблема с этим парсером состоит в том, что он не предусматривает ничего между открывающим и закрывающими тегами. То есть настало время подумать о рекурсии и о том как организовывать потомков. А пока можно проверить как работает парсер элемента.
* (ql:quickload 'toy-engine)
To load "toy-engine":
Load 1 ASDF system:
toy-engine
; Loading "toy-engine"
(TOY-ENGINE)
* (in-package :toy-engine)
#<PACKAGE "TOY-ENGINE">
* (defparameter *str* "table border=\"1\" width=\"50%\" ></table>")
*STR*
* (parse-html *str*)
#<ELEMENT-NODE {100504E943}>
* (gethash "width" (element-node-attrs *))
"50%"
T
* (pp->dot "element-node.dot" (lambda () (pp-dom **)))
"}"
*
Рекурсия
Так как мы создаём узел только после того, как создадим всех его потомков, то логично будем накапливать их в списке и потом просто передавать его в конструктор узла. Самой интересной функцией будет та, что разбирает несколько расположенных друг за другом узлов в список будущих потомков.
Но сначала парсер одного единственного узла:
(parse-node ()
"Text or node"
(let ((oldindex index))
(or (matchit
{ !(parse-comment-or-element)
!(parse-text)})
(progn (setf index oldindex) nil))))
Он использует маленький вспомогательный парсер, который нужен для отката назад в том случае, если встретился не комментарий и не элемент. Дело в том, что элементарные совпадения вроде #\< или "example" использованные внутри последовательности [] нельзя откатить, если они сработали.
(parse-comment-or-element ()
"< {comment element}"
(let ((oldindex index))
(or (matchit
[#\< {!(parse-comment) !(parse-element)}])
(progn (setf index oldindex) nil))))
Проверим, что эта функция распознаёт и создаёт разные типы узлов:
* (ql:quickload 'toy-engine)
To load "toy-engine":
Load 1 ASDF system:
toy-engine
; Loading "toy-engine"
(TOY-ENGINE)
* (in-package :toy-engine)
#<PACKAGE "TOY-ENGINE">
* (defparameter *str-text* "table border=\"1\" width=\"50%\" ></table>")
*STR-TEXT*
* (defparameter *text* (parse-html *str-text*))
*TEXT*
* (defparameter *str-comment* "<!-- coomn -->")
*STR-COMMENT*
* (defparameter *comment* (parse-html *str-comment*))
*COMMENT*
* (defparameter *str-element* "<table border=\"1\" width=\"50%\" ></table>>")
*STR-ELEMENT*
* (defparameter *element* (parse-html *str-element*))
*ELEMENT*
* *element*
#<ELEMENT-NODE {100516F043}>
* *text*
#<TEXT-NODE {100503DD53}>
* *comment*
#<COMMENT-NODE {10050C6A93}>
*
Собираем несколько узлов в список:
(parse-nodes ()
"Children"
(let ((oldindex index) children node)
(if (matchit
$[!(setf node (parse-node)) !(push node children)])
(reverse children)
(progn (setf index oldindex) nil))))
Проверяем насколько успешно эта функция распознает строку с разными составными частями HTML:
* (ql:quickload 'toy-engine)
To load "toy-engine":
Load 1 ASDF system:
toy-engine
; Loading "toy-engine"
(TOY-ENGINE)
* (in-package :toy-engine)
#<PACKAGE "TOY-ENGINE">
* (defparameter *str* "Text rr<!-- coomn --> <p></p>")
*STR*
* (defparameter *ch* (parse-html *str*))
*CH*
* *ch*
(#<TEXT-NODE {1005AD9AA3}> #<COMMENT-NODE {1005AD9BE3}>
#<TEXT-NODE {1005AD9EE3}> #<ELEMENT-NODE {1005ADA5E3}>)
*
Если теперь изменить тело функции parse-html на
(make-instance 'node :children (parse-nodes))
тем самым сделав все распознанные узлы на верхнем уровне потомками некого узла типа node.
* (ql:quickload 'toy-engine)
To load "toy-engine":
Load 1 ASDF system:
toy-engine
; Loading "toy-engine"
(TOY-ENGINE)
* (in-package :toy-engine)
#<PACKAGE "TOY-ENGINE">
* (defparameter *str* "Text rr<!-- coomn --> <p></p>")
*STR*
* (defparameter *ch* (parse-html *str*))
*CH*
* (pp->dot "children.dot" (lambda () (pp-dom *ch*)))
"}"
*
Окончательно парсер элемента содержит запуск рекурсии:
(parse-element ()
"<tagname $[attr=value]> ??? </tagname>"
(let ((oldindex index)
ch tagname attrs children)
(or (matchit
[!(setf tagname (parse-tagname))
{!(setf attrs (parse-attrs)) !t}
#\>
{!(setf children (parse-nodes)) !t}
!(parse-closing-tag tagname)
!(make-element-node tagname attrs children)])
(progn (setf index oldindex) nil))))
Разбор сложного примера:
* (ql:quickload 'toy-engine)
To load "toy-engine":
Load 1 ASDF system:
toy-engine
; Loading "toy-engine"
.
(TOY-ENGINE)
* (in-package :toy-engine)
#<PACKAGE "TOY-ENGINE">
* (defparameter *str* "Text rr<!-- coomn --> <p>another text<table color=\"red\"><tr>Row</tr></table></p>")
*STR*
* (defparameter *ch* (parse-html *str*))
*CH*
* (pp->dot "parse-html.dot" (lambda () (pp-dom *ch*)))
"}"
*
