d-testlinks.el

    

;;; d-testlinks.el --- An automated internal hyperlink checker

;; Copyright (C) 2006-2011 Davin Pearson

;; Author/Maintainer: Davin Max Pearson <http://davin.50webs.com>
;; Keywords: Automatic Hyperlink Checker
;; Version: 1.0

;;; Commentary:

;; This file is not part of GNU Emacs.

;; This code provides automatic validation of href= and src= links.
;; For each broken link, a log line is printed to the screen.  Note
;; that this file only works with local (user's own hard drive)
;; relative links, not internet addresses.

;;; Limitation of Warranty

;; 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 3 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 detail.
;;
;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs, see the file COPYING.  If not, see:
;;
;; <http://www.gnu.org/licenses/gpl-3.0.txt>.


;;; Install Instructions:
;; See the following URL for the latest info and a tarball:
;;
;; <http://davin.50webs.com/research/2010/mopa2e2.html#d-testlinks>
;;
;; Then untar the tarball to a folder pointed to by the Emacs variable
;; load-path and add the following line to your ~/.emacs file.
;;
;; (require 'd-testlinks)

;;; Known Bugs:

;; Certain hyperlinks are hard wired into my Website links checker:
;;
;; http://davin.50webs.com
;;
;; but this should not stop users from finding this code useful.
;; For example the above URL could be changed to suit your own
;; Website.

;;; Code:

;; (setq first "b.html")
;; (setq second "foo")
;; (testlinks--find-name "b.html" "foo")
(defun testlinks--find-name (first second)
  (if (and (not (string= first ""))
           (file-exists-p first)
           (string-match "\\.[hH][tT][mM][lL]?$" first))
      (save-excursion
        (let* ((is-editing (d-currently-editing-file first))
               (is-readonly nil))
          (find-file first)
          (setq is-readonly buffer-read-only)
          (setq buffer-read-only t)
          (setq second (regexp-quote second))
          (let ((result (cond ((save-excursion
                                 (goto-char (point-min))
                                 (re-search-forward (concat "name=" second "[ \r\n\t>]") nil t))
                               t)
                              ((save-excursion
                                 (goto-char (point-min))
                                 (re-search-forward (concat "name='" second "'") nil t))
                               t)
                              ((save-excursion
                                 (goto-char (point-min))
                                 (re-search-forward (concat "name=\"" second "\"") nil t))
                               t)
                              (t
                               nil))))
            (if is-editing
                (setq buffer-read-only is-readonly)
              (kill-buffer nil))
            result)))))

(defun testlinks--search-for-url-regexp (re)

;;(message "buffer=%s cq1" (buffer-name))

  (if testlinks--verbose
      (save-excursion
        (set-buffer testlinks--lbuf)
        (insert "searching for re: [" re "]\n")))

(let ((case-fold-search t)) ; lexical scoping should make this unecessary...
    (goto-char (point-min))
    (while (re-search-forward re nil t)

(let (s)

(setq s (buffer-substring-no-properties (match-beginning 1) (match-end 1)))

(if testlinks--verbose
            (save-excursion
              (set-buffer testlinks--lbuf)
              (insert "testing link: [" s "]\n")))

(when (string-match "^file:/+\\(.*\\)" s)
          (setq s (substring s (match-beginning 1) (match-end 1))))

(when (string-match "^http://davin.50webs.com/\\(.*\\)" s)
          (setq s (concat "c:/home/hairy-lemon/output/50webs-com/"
                          (substring s (match-beginning 1) (match-end 1))))
          ;;(save-excursion (set-buffer testlinks--lbuf) (insert "**** munged=" s "\n"))
          )

(if (or (string-match "^http:" s)
                (string-match "^https:" s)
                (string-match "^javascript:" s)
                (string-match "^mailto:" s))
            (progn
              ;; NOTE: do nothing
              )
          (if (string-match "^\\([^#]*\\)#\\([^#]*\\)$" s)
              (let (first second line)
                (setq first (substring s (match-beginning 1) (match-end 1)))
                (setq second (substring s (match-beginning 2) (match-end 2)))

;;(message "first=%s" first)
                ;;(message "second=%s" second)

                (if (string= first "")
                    (setq first (buffer-file-name)))

(if (not (testlinks--find-name first second))
                    (save-excursion
                      (setq line (d-what-line))
                      (set-buffer testlinks--lbuf)
                      (assert (boundp 'testlinks--bname))
                      (insert testlinks--bname ":" (format "%d" line) ": Error=" s "\n")
                      )))
            (if (or (string= s "")
                    (not (file-exists-p s)))
                (save-excursion
                  (setq line (d-what-line))
                  (set-buffer testlinks--lbuf)
                  (assert (boundp 'testlinks--bname))
                  (insert testlinks--bname ":" (format "%d" line) ": Error=" s "\n")
                  ))))))))

;; (insert "sdff-" 123 "-foo")
;; (insert "sdff-" (format "%d" 123) "-foo")

(defun testlinks--search-for-regexp (re cfs)
  (let ((case-fold-search cfs)
        (name (buffer-file-name))
        (line nil))
    (goto-char (point-min))
    (while (re-search-forward re nil t)
      (save-excursion
        (setq line (d-what-line))
        (set-buffer testlinks--lbuf)
        (insert testlinks--bname ":" (format "%d" line) ": Regexp Error=" re ", file=" name "\n"))
      ;;(message "buffer=%s" (buffer-name))
      ;;(debug)
      )))

(defvar testlinks--bufname "*testlinks*")

(defvar testlinks--verbose nil)

;;(symbol-function 'message)

;; (testlinks-inner "~/hairy-lemon/output")
(defun testlinks-inner (dir &optional currently-recursing)

;;  (let ((message-old))
  ;;    (when (and (not currently-recursing) (symbol-function 'message))
  ;;      (fset 'message-old (symbol-function 'message))
  ;;      (fset 'message (lambda (msg &rest rest)
  ;;                       (if (not (string-match "^Mark set$" msg))
  ;;                          (apply message-old msg rest)))))

  ;;(message "dir=%s" dir)
  ;; make sure it ends with a slash!
  (if (not (string= "/" (substring dir -1)))
      (setq dir (concat dir "/")))

(if (not currently-recursing)
      (progn
        (if (get-buffer testlinks--bufname)
            (kill-buffer testlinks--bufname))
        (save-excursion
          (set-buffer (generate-new-buffer testlinks--bufname))
          (compilation-mode)
          (read-only-mode -1)
          )))

(setq testlinks--lbuf (or (get-buffer testlinks--bufname) (generate-new-buffer testlinks--bufname)))

(set-buffer testlinks--lbuf)
  (insert "* called testlinks with args dir=" dir ", and currently-recursing=" (prin1-to-string currently-recursing) "\n")
  (if (not currently-recursing)
      (insert "* \n"))

(let* ((list (d-directory-files-no-dotdotdot dir))
         (ptr  list)
         (len  (length list))
         (count 0))

;;(insert (concat "*** going to recurse on list: " (prin1-to-string ptr) "\n"))
    (while ptr
      (if (not currently-recursing)
          (message "Progress#1 %s%%" (/ (* 100 count) len)))
      (incf count)
      (setq subdir (concat dir (car ptr)))
      ;;(insert "** testing for subdir: " subdir "\n")
      (if (file-directory-p subdir)
          (progn
            ;;(insert "*** test succeeded!\n")
            (testlinks-inner subdir t))
        ;;(insert "** test failed!\n")
        )
      (setq ptr (cdr ptr))))

;; (cons '("\\.[hH][tT][mL][lL]?$" . fundamental-mode) auto-mode-alist)
  (let* ((list             (d-directory-files dir t ".*\\.\\([pP][hH][pP]\\|[hH][tT][mM][lL]?\\)$" t))
         (ptr              list)
         (case-fold-search t)
         ;; COOL! temporarily disables HTML mode!
         (auto-mode-alist  nil)
         (len              (length list))
         (count            0))
    (while ptr

(let* ((is-editing (d-currently-editing-file (car ptr)))
             (is-readonly nil))

(if (not currently-recursing)
            (message "Progress#2 %s%%" (/ (* 100 count) len)))

(incf count)

(find-file (car ptr))
        (setq is-readonly buffer-read-only)
        (setq buffer-read-only t)

(setq testlinks--bname (buffer-file-name))
        ;;(message "Visiting file: %s" testlinks--bname)

        (if testlinks--verbose
            (save-excursion
              (set-buffer testlinks--lbuf)
              (insert "visiting file: '" testlinks--bname "'\n")))

;; NOTE: don't need to smeg         ;; NOTE: don't need to smeg <!-- --> since they can appear inside <...> tags
        ;;
        (testlinks--search-for-url-regexp "<a[ \t\r\n]+href=\\([^\"'>][^ >]*\\)[ \t\r\n>]")
        (testlinks--search-for-url-regexp "<a[ \t\r\n]+href=\"\\([^\"]+\\)\"")
        (testlinks--search-for-url-regexp "<a[ \t\r\n]+href='\\([^']+\\)'")
        (testlinks--search-for-url-regexp "<img[ \t\r\n]+src=\\([^\"'>][^ >]+\\)[ \t\r\n>]")
        (testlinks--search-for-url-regexp "<img[ \t\r\n]+src=\"\\([^\"]+\\)\"")
        (testlinks--search-for-url-regexp "<img[ \t\r\n]+src='\\([^']+\\)'")
        (testlinks--search-for-url-regexp "<link rel=\"[^\"]+\" href=\"\\([^\"]+\\)\"")

(when prefs-home-emacs-p
          ;;(message "buffer=%s" (buffer-name))
          ;;(debug)
          (testlinks--search-for-regexp "SECT_" nil)
          (testlinks--search-for-regexp "QEST_" nil)
          (testlinks--search-for-regexp "fuck" t)
          ;;(testlinks--search-for-regexp "shit" t)
          ;;(testlinks--search-for-regexp "mailblocks.com" t)
          )

(if is-editing
            (setq buffer-read-only is-readonly)
          (kill-buffer nil))
        (setq ptr (cdr ptr))
        )
      )
    )

;;(when (and (not currently-recursing) message-old)
  ;;  (fset 'message message-old))
  )

;;(defun message (&rest rest))
;; (message "abc")

(defun testlinks ()
  (interactive)
  (let (dir is-a-dir time-start time-stop dif)
    (setq time-start (current-time))
    (setq dir (read-file-name "Enter dir: " default-directory))
    (save-some-buffers 'NOQUESTIONS)
    (setq is-a-dir (car (file-attributes dir)))
    (if (not is-a-dir) (setq dir (file-name-directory dir)))
    (testlinks-inner dir)
    (setq time-stop (current-time))
    (setq dif (d-seconds-of-time-difference time-start time-stop))

(progn
      (set-buffer testlinks--lbuf)
      (goto-char (point-max))
      (insert "**** TIME TOOK: = " (d-seconds-to-readable-string dif) "\n"))

(if prefs-home-emacs-p
        (save-excursion
          (set-buffer testlinks--lbuf)
          (goto-char (point-min))
          (flush-lines "c:/home/hairy-lemon/output/50webs-com/email.html:"))) ;;; encoded email mailto:

    (progn
      (switch-to-buffer testlinks--bufname)
      (goto-char (point-max))
      )

(d-random-play-emacs-midi)

))

(defun d-random-play-emacs-midi (&optional file)
  (interactive)
  (progn
    (if (not file)
        (setq file "/media/www/C1TB/sound-samples/emacs/game-over-b.wav"))
    (play-sound (list 'sound :file file :volume 1.0))
    )
  )

(provide 'd-testlinks)