;;; sdoc.el
;;;
;;; Find information from structured ASCII-files such as Amiga Autodocs,
;;; Unix man pages and programming language header and include files. It is
;;; possible to create match entries for any file format really, using the
;;; appropriate filter function.
;;;
;;; Copyright © 1995 Torbjörn Axelsson
;;;
;;; This file is NOT part of the GNU Emacs.
;;;
;;; Verbatim copies of this file may be freely redistributed together with
;;; its documentation file.
;;;
;;; Modified versions of this file may be redistributed provided that this
;;; notice remains unchanged, the file contains prominent notice of author
;;; and time of modifications, and redistribution of the file is not
;;; further restricted in any way.
;;;
;;; This file is distributed `as is', without warranties of any kind. 
;;;
;;; To contact the author, send email to torax@ctrl-c.liu.se.
;;;
;;; History:
;;; v1.00 1995-01-14: Developed using GNU Emacs 18.58, Amiga port1.26DG
;;;                   Features searching, adding matches and merging
;;;                   databases.
;;;
;;; Future:
;;; Pri Project
;;; top (Semi)automatic scripts for creating multiple database entries from
;;;     documentation files.
;;; top Implementing the filter function. (Such as stripping formatting
;;;     codes from hypertext documents, should work on a region.)
;;; low Use techinfo for the doc file.

(provide 'sdoc)

(defvar sdoc-buffer "*Sdoc*" "*Name of the Sdoc output buffer.")
(defvar sdoc-database "/users/torax/sdoc/sdoc.database" "*Full path to the Sdoc database file.")

;;; These buffer local variables are used for narrowing search and editing of the database file.
(make-variable-buffer-local 'sdoc-eofiles) ; End of file list.
(make-variable-buffer-local 'sdoc-botypes) ; Beginning of type list.
(make-variable-buffer-local 'sdoc-eotypes) ; End of type list.
(make-variable-buffer-local 'sdoc-bomatches)  ; Beginning of matchlist.

;;; Basic search function

(defun sdoc (about)
  "Lookup a word using the Sdoc database." 
  (interactive "sSearch for: ")
  (save-excursion
    (with-output-to-temp-buffer sdoc-buffer
      (let ((database-buffer (find-file-noselect sdoc-database))
	    (work-buffer (get-buffer-create " sdoc-work-buffer"))
	    found-match)
	(sdoc-print "Sdoc looking for: " about "\n\n")
	(setq about (concat "^" about "\^L"))
	(if (not (sdoc-databasep database-buffer))
	    (error "%s is not a valid Sdoc database" sdoc-database))
	(set-buffer database-buffer)
	(goto-char sdoc-bomatches)
	(while	(setq found-match (sdoc-grab-match about database-buffer))
	  ;; Find and add the text to the help buffer.
	  (set-buffer work-buffer)
	  (erase-buffer)
	  (insert-file-contents (nth 1 found-match))
	  (delete-region (nth 5 found-match) (point-max))
	  (delete-region (nth 4 found-match) (point-min))
	  (sdoc-print (nth 2 found-match) " found: " (car found-match) "\nData file: "
		      (nth 1 found-match) "\n----------S-T-A-R-T----------\n"
		      (buffer-string)
		      (if (not (equal (buffer-substring (point-max) (1- (point-max))) "\n"))
			  "\n" "")
		      "----------E-N-D--------------\n\n"))
	(kill-buffer work-buffer)))))

;;; Database management

(defun sdoc-merge-buffer-to-database (&optional buff)
  "Merges the database in BUFFER with the main Sdoc database file.
BUFFER defaults to the current buffer."
  (interactive "bMerge Sdoc database with buffer ")
  (save-excursion
    (if (not buff)
	(setq buff (current-buffer)))
    (let ((database-buffer (find-file-noselect sdoc-database))
	  (newbase-buffer buff))
      (if (not (sdoc-databasep database-buffer))
	  (error "Sdoc default database buffer \"%s\" is corrupt." sdoc-database))
      (if (not (sdoc-databasep newbase-buffer))
	  (error "Trying to add an incorrect database buffer."))
      (set-buffer newbase-buffer)
      (goto-char sdoc-bomatches)
      (while
	  (sdoc-add-match (sdoc-grab-match "^.*\^L" newbase-buffer) database-buffer)))))

(defun sdoc-add-region-as-match (id matchtype startpos endpos &optional filter)
  "*Add the current region as an entry in the Sdoc database, supply ID and MATCHTYPE.
When called from other lisp functions, add STARTPOS and ENDPOS and
optional FILTER"
  (interactive "sid: \nsmatchtype: \nr")
  (if buffer-file-name
      (sdoc-add-match (list id buffer-file-name matchtype filter startpos endpos)
		  (find-file-noselect sdoc-database))
    (error "Current buffer not visiting a file, cannot add to Sdoc database")))

(defun sdoc-add-match (match &optional buff)
  "Add a MATCH entry to the (&optional) BUFFER (current). If MATCH is nil return nil, if all ok return t.
If the buffer is completely empty, will create the database.
Will fail if it is a non empty non sdoc database buffer.

The format of the match entry is a list:
matchstring filename matchtype filter startpos endpos

matchstring - string with the id of the match
filename - string with the complete filename to look up
matchtype - string saying what type of match this is
filter - string with the name of the filter function or nil if no filter needed
startpos, endpos - integers with the start and end of the region to display"
  (and
   match
   (save-excursion
     (if buff
	 (set-buffer buff))
     (if (not (sdoc-databasep (current-buffer)))
	 (if (or (/= 1 (point-min))
		 (/= 1 (point-max)))
	     (error "Trying to add a match to a non sdoc database buffer.")
	   (insert
	    (concat
	     (nth 1 match) "\n\^L\n" (nth 2 match)
	     (if (nth 3 match) "\^L")
	     (nth 3 match) "\n\^L\n"
	     (nth 0 match) "\^L1\^L0\^L" (nth 4 match) "\^L" (nth 5 match) "\n"))
	   (sdoc-databasep (current-buffer)))
       (let* ((fileno (sdoc-add-filename (nth 1 match)))
	      (matchno (sdoc-add-matchtype (nth 2 match) (nth 3 match)))
	      (matchstring (concat (nth 0 match) "\^L" fileno "\^L" matchno "\^L" (nth 4 match) "\^L"
				   (nth 5 match) "\n")))
	 (goto-char sdoc-bomatches)
	 (if (not (search-forward matchstring nil 1))
	     (let (buffer-read-only)
	       (insert matchstring))))
       t))))

(defun sdoc-databasep (buff)
  "Check if BUFFER is a well formed Sdoc database and if so set the sdoc-bo* and sdoc-eo* variables.."
  (save-excursion
    (set-buffer buff)
    (if (and
	 (markerp sdoc-eofiles)
	 (markerp sdoc-botypes)
	 (markerp sdoc-eotypes)
	 (markerp sdoc-bomatches))
	t
      (goto-char (point-min))
      (and
       (looking-at
	(concat "\\`" ; Start of buffer
		"\\(^[^\^L\n]+\n\\)+\^L\n" ;Filenames
		"\\(\\([^\^L\n]+\^L\\)?[^\^L\n]+\n\\)+\^L\n" ; Types (w filter functions)
		"\\(^[^\^L\n]+\^L[0-9]+\^L[0-9]+\^L[0-9]+\^L[0-9]+\n\\)+\\'"))
       (let ((md (match-data)))
	 (setq sdoc-eofiles (make-marker))
	 (setq sdoc-botypes (make-marker))
	 (setq sdoc-eotypes (make-marker))
	 (setq sdoc-bomatches (make-marker))
	 (set-marker sdoc-eofiles (nth 3 md))
	 (set-marker sdoc-botypes (nth 4 md))
	 (set-marker sdoc-eotypes (nth 5 md))
	 (set-marker sdoc-bomatches (nth (- (length md) 2) md))
	 (setq mode-line-buffer-identification '("Sdoc: %18b"))
	 (setq buffer-read-only t)
	 t)))))

;;; Support functions

(defun sdoc-print (&rest l)
  "Print multiple objects to stdout"
  (mapcar 'princ l))

(defun sdoc-add-filename (filename)
  "Add FILENAME to the files section of current buffer. Returns the filenumber."
  (if filename
      (save-excursion
	(goto-char (point-min))
	(if (search-forward (concat filename "\n") sdoc-eofiles t)
	    (count-lines (point) (point-min))
	  (goto-char (1- sdoc-eofiles))
	  (let (buffer-read-only)
	    (insert "\n" filename))
	  (count-lines (point) (point-min))))))

(defun sdoc-add-matchtype (type &optional filter)
  "Add a match named TYPE with optional FILTER to database. Return matchno of the TYPE/FILTER pair."
  (save-excursion
    (goto-char sdoc-botypes)
    (let (buffer-read-only (typeline (concat type (if filter "\^L") filter)))
      (if (search-forward (concat typeline "\n") sdoc-eotypes t)
	  (1- (count-lines (point) sdoc-botypes))
	(goto-char (1- sdoc-eotypes))
	(let (buffer-read-only)
	  (insert "\n" typeline))
	(1- (count-lines (point) sdoc-botypes))))))
  
(defun sdoc-grab-match (regexp &optional buff)
  "Find the next match matching REGEXP in (optional) BUFFER.
Will return a list (match filename matchtype filter startpos endpos)"
  (let ((cbuff (current-buffer)) result)
    (if buff
	(set-buffer buff))
    (if (not (sdoc-databasep (current-buffer)))
	(progn
	  (set-buffer cbuff)
	  (error "Trying to extract matchdata from non-database buffer.")))
    (cond
     ((re-search-forward regexp nil t)
      (beginning-of-line)
      (if (not (looking-at "^\\([^\^L\n]+\\)\^L\\([0-9]+\\)\^L\\([0-9]+\\)\^L\\([0-9]+\\)\^L\\([0-9]+\\)\n"))
	  (error "Bad database entry"))
      (let ((tmp (list (buffer-substring (match-beginning 1) (match-end 1))
		       (string-to-int (buffer-substring (match-beginning 2) (match-end 2)))
		       (string-to-int (buffer-substring (match-beginning 3) (match-end 3)))
		       (string-to-int (buffer-substring (match-beginning 3) (match-end 3)))
		       (string-to-int (buffer-substring (match-beginning 4) (match-end 4)))
		       (string-to-int (buffer-substring (match-beginning 5) (match-end 5))))))
	(setcar (cdr tmp) (sdoc-grab-filename (nth 1 tmp)))
	(setcar (nthcdr 2 tmp) (sdoc-grab-matchtype (nth 2 tmp)))
	(setcar (nthcdr 3 tmp) (sdoc-grab-filter (nth 3 tmp)))
	(forward-line)
	(setq result tmp))))
    (set-buffer cbuff)
    result))

(defun sdoc-grab-filename (fileno &optional buff)
  "Return the filename of FILENO in optional BUFFER."
  (save-excursion
    (if buff
	(set-buffer buff))
    (goto-line fileno)
    (let ((bol (point)))
      (end-of-line)
      (buffer-substring bol (point)))))

(defun sdoc-grab-matchtype (matchno &optional buff)
  "Return the matchtype for match number MATCHNO in optional BUFFER."
  (save-excursion
    (if buff
	(set-buffer buff))
    (goto-char sdoc-botypes)
    (forward-line matchno)
    (let ((bol (point)))
      (re-search-forward "[^\^L\n]+")
      (buffer-substring bol (point)))))

(defun sdoc-grab-filter (matchno &optional buff)
  "Return the filter for match number MATCHNO in optional BUFFER."
  (save-excursion
    (if buff
	(set-buffer buff))
    (goto-char sdoc-botypes)
    (forward-line matchno)
    (if	(looking-at "[^\^L\n]+\^L\\(.+\\)")
	(buffer-substring (match-beginning 1) (match-end 1)))))