1 ;;; WARNING: lhtml will conflict with any handler which also uses lists. 2 ;;; xmls, for instance (though I think that's at least 3 ;;; structurally compatible). Sorry, but that's the way it goes. 4 (in-package #:oh-ducks.traversal) 5 6 (defvar *lhtml-family-tree* nil) 7 8 (defun in-hash (key hash) 9 (multiple-value-bind (val present-p) (gethash key hash) 10 (declare (ignore val)) 11 present-p)) 12 13 (defun %mark-parents (parent children) 14 (dolist (item children) 15 (setf (gethash item *lhtml-family-tree*) parent) 16 (%mark-parents item (element-children item)))) 17 18 ;; WARNING: This won't produce sane results for nested (match)es, because we 19 ;; have no way to bind in a large enough scope. 20 (defmethod unify:unify ((template oh-ducks::css-selector-template) 21 (element list) 22 &optional (env (unify:make-empty-environment)) 23 &key) 24 (if (and *lhtml-family-tree* 25 (in-hash element *lhtml-family-tree*)) 26 (call-next-method) 27 (let ((*lhtml-family-tree* (make-hash-table :test 'eq))) 28 (%mark-parents nil (list element)) 29 (%mark-parents element (element-children element)) 30 (call-next-method)))) 31 32 ;;; general accessors 33 34 (defmethod element-children ((element list)) 35 (remove-if-not (lambda (x) (and (listp x) (keywordp (car x)))) 36 (cddr element))) 37 38 (defmethod element-parent ((element list)) 39 (multiple-value-bind (parent present?) 40 (gethash element *lhtml-family-tree*) 41 (if present? 42 parent 43 (error "unable to determine parent")))) 44 45 (defmethod element-attribute ((attribute symbol) (element list)) 46 (cadr (assoc attribute (cadr element)))) 47 (defmethod element-attribute ((attribute string) (element list)) 48 (element-attribute (intern (string-upcase attribute) :keyword) element)) 49 50 (defmethod element-type ((element list)) 51 (car element)) 52 53 (defmethod element-content ((element list)) 54 (cddr element))