;;; anchor-check.el --- check XHTML document name anchors

;; Copyright (C) 2001  Alex Schroeder

;; Emacs Lisp Archive Entry
;; Filename: anchor-check.el
;; Version: 1.0.1
;; Keywords: hypermedia
;; Author: Alex Schroeder <alex@gnu.org>
;; Maintainer: Alex Schroeder <alex@gnu.org>
;; Description: check XHTML document name anchors
;; URL: http://www.geocities.com/kensanata/emacs.html
;; Compatibility: Emacs20, XEmacs21

;; This file is not part of GNU Emacs.

;; This 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, or (at your option) any later
;; version.
;;
;; This 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 GNU Emacs; see the file COPYING.	If not, write to the
;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
;; MA 02111-1307, USA.

;;; Commentary:

;; This requires xml-parse.el by John Wiegley <johnw@gnu.org>.  Get it
;; from this URL: http://www.gci-net.com/~johnw/emacs.html.

;; Open an XHTML file and use M-x anchor-check RET.  This will tell you
;; all A NAME tags that are not referenced by A HREF tags, and it will
;; tell you all A HREF tags that reference nonexisting A NAME tags.
;; Very usefull for big documents with lots of internal links.

;; Note that anchor-check will only check *local* references, ie. A HREF
;; starting with "#"!

(require 'xml-parse)

;;; Some xml-parse redefinitions required for xml-parse 1.4, these will
;;; be fixed in later versions.

;; new
(defsubst xml-tag-with-attributes-p (tag)
  "Does the TAG have attributes or not?"
  (listp (car tag)))

;; handle tags without attributs
(defsubst xml-tag-name (tag)
  "Return the name of an xml-parse'd XML TAG."
  (cond ((xml-tag-text-p tag)
	 (car tag))
	((xml-tag-with-attributes-p tag)
	 (caar tag))
	(t (car tag))))

(require 'cl); for set-difference

(defun anchor-check ()
  "Check all anchor references within the current buffer.
This checks wether all <A HREF=\"#anchor\">...</A> elements actually
match an existing <A NAME=\"anchor\">...</A> elements."
  (interactive)
  (save-excursion
    (goto-char (point-min))
    (let* ((doc (read-xml))
	   (refs (anchor-ref-list doc))
	   (names (anchor-name-list doc))
	   (broken-refs (mapconcat 'identity
				   (set-difference refs names :test 'equal)
				   ", "))
	   (broken-names (mapconcat 'identity
				    (set-difference names refs :test 'equal)
				    ", ")))
      (if (and (string= broken-refs "")
	       (string= broken-names ""))
	  (message "Anchors checked, no problems found")
	(with-output-to-temp-buffer "*Anchor Check*"
	  (when (not (string= broken-refs ""))
	    (princ (format "Broken references: %s" broken-refs)))
	  (when (and (not (string= broken-refs ""))
		     (not (string= broken-names "")))
	    (princ "\n\n"))
	  (when (not (string= broken-names ""))
	    (princ (format "Unreferenced anchors: %s" broken-names))))))))

(defun anchor-ref-list (element)
  "Return all anchor references withing ELEMENT."
  (delq nil
	(mapcar (lambda (x)
		  (when (char-equal (aref x 0) ?#); only local href!
		    (substring x 1)))
		(anchor-list-1 element "href" nil))))

(defun anchor-name-list (element)
  "Return all anchor names withing ELEMENT."
  (anchor-list-1 element "name" nil))

(defun anchor-list-1 (element attribute result)
  "Accumulate anchor references from ELEMENT with ATTRIBUTE.
Append the elements to RESULT and return it.  This function
is called recursively on all children of ELEMENT."
  (cond ((stringp element)
	 result)
	((and (string= (xml-tag-name element) "a"); all A tags
	      (xml-tag-attr element attribute))
	 (cons (xml-tag-attr element attribute) result))
	(t
	 (let ((children (xml-tag-children element))
	       child)
	   (while children
	     (setq child (car children)
		   children (cdr children))
	     (setq result (anchor-list-1 child attribute result))))
	 result)))