;;;; -*- mode:emacs-lisp;coding:utf-8 -*-
;;;;**************************************************************************
;;;;FILE:               pjb-html.el
;;;;LANGUAGE:           emacs lisp
;;;;SYSTEM:             POSIX
;;;;USER-INTERFACE:     NONE
;;;;DESCRIPTION
;;;;
;;;;    Skip over <tag>...</tag>.
;;;;
;;;;    We need also up-tag and down-tag, etc.
;;;;
;;;;AUTHORS
;;;;    <PJB> Pascal Bourguignon <pbourguignon@ravenpack.com>
;;;;MODIFICATIONS
;;;;    2007-04-04 <PJB> Created.
;;;;BUGS
;;;;
;;;;    Doesn't work at beginning or end of buffer for tests are not implemented.
;;;;
;;;;    Doesn't like non-balanced tags, unfortunately some DTD prevent some
;;;;    tags to be closed AFAIK.  This is not handled.
;;;;
;;;;LEGAL
;;;;    GPL
;;;;
;;;;    Copyright Pascal Bourguignon 2007 - 2011
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU General Public License
;;;;    as published by the Free Software Foundation; either version
;;;;    2 of the License, or (at your option) any later version.
;;;;
;;;;    This program is distributed in the hope that it will be
;;;;    useful, but WITHOUT ANY WARRANTY; without even the implied
;;;;    warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR
;;;;    PURPOSE.  See the GNU General Public License for more details.
;;;;
;;;;    You should have received a copy of the GNU General Public
;;;;    License along with this program; if not, write to the Free
;;;;    Software Foundation, Inc., 59 Temple Place, Suite 330,
;;;;    Boston, MA 02111-1307 USA
;;;;**************************************************************************

(require 'cl)
(require 'pjb-cl)



(defun pjb-parse-xml (xml)
  "Parse the XML string."
  (with-temp-buffer
    (insert xml)
    (xml-parse-region (point-min) (point-max))))

(defun pjb-parse-html (html)
  "Parse the HTML string."
  (pjb-parse-xml html))


(defun pjb-find-html-tag (tag html)
  (cond
    ((atom html) nil)
    ((eq tag (car html)) html)
    (t (or (pjb-find-html-tag tag (car html))
           (pjb-find-html-tag tag (cdr html))))))






(defun beginning-of-buffer-p (point)
  ;; (message "Please implement beginning-of-buffer-p again...")
  nil)

(defun end-of-buffer-p (point)
  ;; (message "Please implement end-of-buffer-p again...")
  nil)


(defun skip-to-next-tag ()
  (interactive)
  (loop
     for end   = (progn (forward-sexp  1) (point))
     for start = (prog1 (progn (forward-sexp -1) (point)) (forward-sexp 1))
     until (or (end-of-buffer-p end)
               (string-match "</?[A-Za-z]+[ >]" (buffer-substring start end)))
     finally (return (buffer-substring start end))))


(defun skip-to-previous-tag ()
  (interactive)
  (loop
     for start = (progn (forward-sexp  -1) (point))
     for end   = (prog1 (progn (forward-sexp 1) (point)) (forward-sexp -1))
       do (message "%S" (list start end))
     until (or (beginning-of-buffer-p end)
               (string-match "</?[A-Za-z]+[ >]" (buffer-substring start end)))
     finally (return (buffer-substring start end))))




(defun open-tag-p (tag-string)
  (string-match "\\`<[^/]" tag-string))


(defvar *auto-close-tags*
  '("link" "img" "input" "br" "hr"))

(defun close-tag-p (tag-string)
  (or (string-match "\\(\\`</\\|/ *>\\'\\)" tag-string)
      (member* (tag-name tag-string) *auto-close-tags*
               :test (function string-equal))))

(defun tag-name (tag-string)
  (when (string-match "^</?\\([A-Za-z]+\\)" tag-string)
    (match-string 1 tag-string)))


(defun move-to-tag (n skip-for skip-back openp closep end)
  (dotimes (i n)
    (let* ((open (funcall skip-for))
           (open-name (tag-name open)))
      (cond
        ((funcall openp open)
         (if (funcall closep open)
           (message "open and close %s" open)
           ;; parse until matching close-tag-p that is not open-tag-p
           (loop
              for close = (funcall skip-for)
              initially (message "open tag: %s" open)
              do (cond
                   ((funcall openp close)
                    (funcall skip-back)
                    (move-to-tag 1 skip-for skip-back openp closep end))
                   ;; If not openp, it must be closep.
                   ((string-equal open-name (tag-name close))
                    (message "close tag: %s" close)
                    (return close))
                   (t
                    (error "At %s of body of tag %s"  end open-name))))))
        ((funcall closep open)
         (error "At %s of body of tag %s"  end open-name))))))


(defun forward-tag (&optional n)
  (interactive "p")
  (setf n (or n 1))
  (if (< n 0)
    (backward-tag (- n))
    (move-to-tag n
                 (function skip-to-next-tag)
                 (function skip-to-previous-tag)
                 (function open-tag-p)
                 (function close-tag-p)
                 "end")))


(defun backward-tag (&optional n)
  (interactive "p")
  (setf n (or n 1))
  (if (< n 0)
    (forward-tag (- n))
    (move-to-tag n
                 (function skip-to-previous-tag)
                 (function skip-to-next-tag)
                 (function close-tag-p)
                 (function open-tag-p)
                 "beginning")))



(defun html-meat ()
  (interactive)
  (local-set-key "\C-c."    'forward-tag)
  (local-set-key "\C-c,"    'backward-tag))






(defun make-element (name attributes children) (list* name attributes children))
(defun element-name (element) (and (listp element) (car element)))
(defun element-attributes (element) (and (listp element) (cadr element)))
(defun element-children (element) (and (listp element) (cddr element)))
(defun set-element-name (element new-name) (setf (car element) new-name))
(defun set-element-attributes (element new-attributes) (setf (cadr element) new-attributes))
(defun set-element-children (new-element children) (setf (cddr element) new-children))
(defsetf element-name set-element-name)
(defsetf element-attributes set-element-attributes)
(defsetf element-children set-element-children)


(defun make-attribute (name value) (list* name value))
(defun attribute-name (attribute) (car attribute))
(defun attribute-value (attribute) (cdr attribute))
(defun set-attribute-name (attribute new-name) (setf (car attribute) new-name))
(defun set-attribute-value (new-attribute value) (setf (cdr attribute) new-value))
(defsetf attribute-name set-attribute-name)
(defsetf attribute-value set-attribute-value)


(defun entity-name-equal-p (a b)
  "xmls entity name may go in namespaces in which case they're lists: (name namespace)"
  (cond
   ((and (stringp a) (stringp b)) (string= a b))
   ((and (stringp a) (symbolp b)) (string= a b))
   ((and (symbolp a) (stringp b)) (string= a b))
   ((and (symbolp a) (symbolp b)) (string= a b))
   ((and (consp a)   (consp b))   (entity-name-equal-p (car a) (car b)))
   ((and (consp a)   (stringp b)) (entity-name-equal-p (car a) b))
   ((and (consp a)   (symbolp b)) (entity-name-equal-p (car a) b))
   ((and (stringp a) (consp b))   (entity-name-equal-p a (car b)))
   ((and (symbolp a) (consp b))   (entity-name-equal-p a (car b)))))


(defun get-attribute-named (element attribute-name)
  (find attribute-name (element-attributes element)
        :test (function string=)
        :key (function attribute-name)))

(defun value-of-attribute-named (element attribute-name)
  (attribute-value (get-attribute-named element attribute-name)))

(defun get-first-child (element)
  (first (element-children element)))

(defun single-string-child-p (element)
  (and (= 1 (length (element-children element)))
       (stringp (get-first-child element))))


(defun get-first-child-tagged (element element-name)
  (find element-name
        (element-children element)
        :test (function entity-name-equal-p)
        :key (function element-name)))

(defun get-first-child-valued (element attribute value)
  (find-if
   (lambda (child) (string= value (value-of-attribute-named child attribute)))
   (element-children element)))

(defun get-children-tagged (element element-name)
  (remove* element-name
          (element-children element)
          :test-not (function entity-name-equal-p)
          :key (lambda (x) (if (consp x) (element-name x) ""))))


(defun get-children-with-tag-and-attribute (element element-name attribute-name attribute-value)
  (remove-if-not (lambda (child)
                   (and (consp child)
                        (entity-name-equal-p (element-name child) element-name)
                        (string= (value-of-attribute-named child attribute-name) attribute-value)))
                 (element-children element)))


(defun find-children-tagged (element element-name)
  (append (get-children-tagged element element-name)
          (mapcan (lambda (child) (find-children-tagged child element-name))
                  (element-children element))))


(defun value-to-boolean (value)
  (string= "true" value))


(defun element-at-path (root path)
  (if (null path)
      root
      (element-at-path (get-first-child-tagged root (first path)) (rest path))))


(provide 'pjb-html)
;;;; THE END ;;;;
ViewGit