;;; WARNING: lhtml will conflict with any handler which also uses lists. ;;; xmls, for instance (though I think that's at least ;;; structurally compatible). Sorry, but that's the way it goes. (in-package #:oh-ducks.traversal) (defvar *lhtml-family-tree* nil) (defun in-hash (key hash) (multiple-value-bind (val present-p) (gethash key hash) (declare (ignore val)) present-p)) (defun %mark-parents (parent children) (dolist (item children) (setf (gethash item *lhtml-family-tree*) parent) (%mark-parents item (element-children item)))) ;; WARNING: This won't produce sane results for nested (match)es, because we ;; have no way to bind in a large enough scope. (defmethod unify:unify ((template oh-ducks::css-selector-template) (element list) &optional (env (unify:make-empty-environment)) &key) (if (and *lhtml-family-tree* (in-hash element *lhtml-family-tree*)) (call-next-method) (let ((*lhtml-family-tree* (make-hash-table :test 'eq))) (%mark-parents nil (list element)) (%mark-parents element (element-children element)) (call-next-method)))) ;;; general accessors (defmethod element-children ((element list)) (remove-if-not (lambda (x) (and (listp x) (keywordp (car x)))) (cddr element))) (defmethod element-parent ((element list)) (multiple-value-bind (parent present?) (gethash element *lhtml-family-tree*) (if present? parent (error "unable to determine parent")))) (defmethod element-attribute ((attribute symbol) (element list)) (cadr (assoc attribute (cadr element)))) (defmethod element-attribute ((attribute string) (element list)) (element-attribute (intern (string-upcase attribute) :keyword) element)) (defmethod element-type ((element list)) (car element)) (defmethod element-content ((element list)) (cddr element))