Mercurial > emacs

;;; forms.el -- Forms Mode - A GNU Emacs Major Mode
;;; SCCS Status     : @(#)@ forms	1.2.7
;;; Author          : Johan Vromans
;;; Created On      : 1989
;;; Last Modified By: Johan Vromans
;;; Last Modified On: Mon Jul  1 14:13:20 1991
;;; Update Count    : 15
;;; Status          : OK

;;; This file is part of GNU Emacs.
;;; GNU Emacs is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY.  No author or distributor
;;; accepts responsibility to anyone for the consequences of using it
;;; or for whether it serves any particular purpose or works at all,
;;; unless he says so in writing.  Refer to the GNU Emacs General Public
;;; License for full details.

;;; Everyone is granted permission to copy, modify and redistribute
;;; GNU Emacs, but only under the conditions described in the
;;; GNU Emacs General Public License.   A copy of this license is
;;; supposed to have been given to you along with GNU Emacs so you
;;; can know your rights and responsibilities.
;;; If you don't have this copy, write to the Free Software
;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
;;;

;;; HISTORY
;;; 1-Jul-1991		Johan Vromans
;;;    Normalized error messages.
;;; 30-Jun-1991		Johan Vromans
;;;    Add support for forms-modified-record-filter.
;;;    Allow the filter functions to be the name of a function.
;;;    Fix: parse--format used forms--dynamic-text destructively.
;;;    Internally optimized the forms-format-list.
;;;    Added support for debugging.
;;;    Stripped duplicate documentation.
;;;
;;; 29-Jun-1991		Johan Vromans
;;;    Add support for functions and lisp symbols in forms-format-list.
;;;    Add function forms-enumerate.

(provide 'forms-mode)

;;; Visit a file using a form.
;;;
;;; === Naming conventions
;;;
;;; The names of all variables and functions start with 'form-'.
;;; Names which start with 'form--' are intended for internal use, and
;;; should *NOT* be used from the outside.
;;;
;;; All variables are buffer-local, to enable multiple forms visits
;;; simultaneously.
;;; Variable 'forms--mode-setup' is local to *ALL* buffers, for it
;;; controls if forms-mode has been enabled in a buffer.
;;;
;;; === How it works ===
;;;
;;; Forms mode means visiting a data file which is supposed to consist
;;; of records each containing a number of fields. The records are
;;; separated by a newline, the fields are separated by a user-defined
;;; field separater (default: TAB).
;;; When shown, a record is transferred to an emacs buffer and
;;; presented using a user-defined form. One record is shown at a
;;; time.
;;;
;;; Forms mode is a composite mode. It involves two files, and two
;;; buffers.
;;; The first file, called the control file, defines the name of the
;;; data file and the forms format. This file buffer will be used to
;;; present the forms.
;;; The second file holds the actual data. The buffer of this file
;;; will be buried, for it is never accessed directly.
;;;
;;; Forms mode is invoked using "forms-find-file control-file".
;;; Alternativily forms-find-file-other-window can be used.
;;;
;;; You may also visit the control file, and switch to forms mode by hand
;;; with M-x forms-mode .
;;;
;;; Automatic mode switching is supported, so you may use "find-file"
;;; if you specify "-*- forms -*-" in the first line of the control file.
;;;
;;; The control file is visited, evaluated using
;;; eval-current-buffer, and should set at least the following
;;; variables:
;;;
;;;	forms-file		    [string] the name of the data file.
;;;
;;;	forms-number-of-fields	    [integer]
;;;			The number of fields in each record.
;;;
;;;	forms-format-list           [list]   formatting instructions.
;;;
;;; The forms-format-list should be a list, each element containing
;;;
;;;  - a string, e.g. "hello" (which is inserted \"as is\"),
;;;
;;;  - an integer, denoting a field number. The contents of the field
;;;    are inserted at this point.
;;;    The first field has number one.
;;;
;;;  - a function call, e.g. (insert "text"). This function call is
;;;    dynamically evaluated and should return a string. It should *NOT*
;;;    have side-effects on the forms being constructed.
;;;    The current fields are available to the function in the variable
;;;    forms-fields, they should *NOT* be modified.
;;;
;;;  - a lisp symbol, that must evaluate to one of the above.
;;;
;;; Optional variables which may be set in the control file:
;;;
;;;	forms-field-sep				[string, default TAB]
;;;			The field separator used to separate the
;;;			fields in the data file. It may be a string.
;;;
;;;	forms-read-only				[bool, default nil]
;;;			't' means that the data file is visited read-only.
;;;			If no write access to the data file is
;;;			possible, read-only mode is enforced.
;;;
;;;	forms-multi-line			[string, default "^K"]
;;;			If non-null the records of the data file may
;;;			contain fields which span multiple lines in
;;;			the form.
;;;			This variable denoted the separator character
;;;			to be used for this purpose. Upon display, all
;;;			occurrencies of this character are translated
;;;			to newlines. Upon storage they are translated
;;;			back to the separator.
;;;
;;;	forms-forms-scroll			[bool, default t]
;;;			If non-nil: redefine scroll-up/down to perform
;;;			forms-next/prev-field if in forms mode.
;;;
;;;	forms-forms-jump			[bool, default t]
;;;			If non-nil: redefine beginning/end-of-buffer
;;;			to performs forms-first/last-field if in
;;;			forms mode.
;;;
;;;	forms-new-record-filter			[symbol, no default]
;;;			If defined: this should be the name of a
;;;			function that is called when a new
;;;			record is created. It can be used to fill in
;;;			the new record with default fields, for example.
;;;			Instead of the name of the function, it may
;;;			be the function itself.
;;;
;;;	forms-modified-record-filter		[symbol, no default]
;;;			If defined: this should be the name of a
;;;			function that is called when a record has
;;;			been modified. It is called after the fields
;;;			are parsed. It can be used to register
;;;			modification dates, for example.
;;;			Instead of the name of the function, it may
;;;			be the function itself.
;;;
;;; After evaluating the control file, its buffer is cleared and used
;;; for further processing.
;;; The data file (as designated by "forms-file") is visited in a buffer
;;; (forms--file-buffer) which will not normally be shown.
;;; Great malfunctioning may be expected if this file/buffer is modified
;;; outside of this package while it's being visited!
;;;
;;; A record from the data file is transferred from the data file,
;;; split into fields (into forms--the-record-list), and displayed using
;;; the specs in forms-format-list.
;;; A format routine 'forms--format' is built upon startup to format
;;; the records.
;;;
;;; When a form is changed the record is updated as soon as this form
;;; is left. The contents of the form are parsed using forms-format-list,
;;; and the fields which are deduced from the form are modified. So,
;;; fields not shown on the forms retain their origional values.
;;; The newly formed record and replaces the contents of the
;;; old record in forms--file-buffer.
;;; A parse routine 'forms--parser' is built upon startup to parse
;;; the records.
;;;
;;; Two exit functions exist: forms-exit (which saves) and forms-exit-no-save
;;; (which doesn't). However, if forms-exit-no-save is executed and the file
;;; buffer has been modified, emacs will ask questions.
;;;
;;; Other functions are:
;;;
;;;	paging (forward, backward) by record
;;;	jumping (first, last, random number)
;;;	searching
;;;	creating and deleting records
;;;	reverting the form (NOT the file buffer)
;;;	switching edit <-> view mode v.v.
;;;	jumping from field to field
;;;
;;; As an documented side-effect: jumping to the last record in the
;;; file (using forms-last-record) will adjust forms--total-records if
;;; needed.
;;;
;;; Commands and keymaps:
;;;
;;; A local keymap 'forms-mode-map' is used in the forms buffer.
;;; As conventional, this map can be accessed with C-c prefix.
;;; In read-only mode, the C-c prefix must be omitted.
;;;
;;; Default bindings:
;;;
;;;	\C-c	forms-mode-map
;;;	TAB	forms-next-field
;;;	SPC 	forms-next-record
;;;	<	forms-first-record
;;;	>	forms-last-record
;;;	?	describe-mode
;;;	d	forms-delete-record
;;;	e	forms-edit-mode
;;;	i	forms-insert-record
;;;	j	forms-jump-record
;;;	n	forms-next-record
;;;	p	forms-prev-record
;;;	q	forms-exit
;;;	s	forms-search
;;;	v	forms-view-mode
;;;	x	forms-exit-no-save
;;;	DEL	forms-prev-record
;;;
;;; Standard functions scroll-up, scroll-down, beginning-of-buffer and
;;; end-of-buffer are wrapped with re-definitions, which map them to
;;; next/prev record and first/last record.
;;; Buffer-local variables forms-forms-scroll and forms-forms-jump
;;; may be used to control these redefinitions.
;;;
;;; Function save-buffer is also wrapped to perform a sensible action.
;;; A revert-file-hook is defined to revert a forms to original.
;;;
;;; For convenience, TAB is always bound to forms-next-field, so you
;;; don't need the C-c prefix for this command.
;;;
;;; Global variables and constants

(defconst forms-version "1.2.7"
  "Version of forms-mode implementation")

(defvar forms-forms-scrolls t
  "If non-null: redefine scroll-up/down to be used with forms-mode.")

(defvar forms-forms-jumps t
  "If non-null: redefine beginning/end-of-buffer to be used with forms-mode.")

(defvar forms-mode-hooks nil
  "Hook functions to be run upon entering forms mode.")
;;;
;;; Mandatory variables - must be set by evaluating the control file

(defvar forms-file nil
  "Name of the file holding the data.")

(defvar forms-format-list nil
  "List of formatting specifications.")

(defvar forms-number-of-fields nil
  "Number of fields per record.")

;;;
;;; Optional variables with default values

(defvar forms-field-sep "\t"
  "Field separator character (default TAB)")

(defvar forms-read-only nil
  "Read-only mode (defaults to the write access on the data file).")

(defvar forms-multi-line "\C-k"
  "Character to separate multi-line fields (default ^K)")

(defvar forms-forms-scroll t
  "Redefine scroll-up/down to perform forms-next/prev-record when in
 forms mode.")

(defvar forms-forms-jump t
  "Redefine beginning/end-of-buffer to perform forms-first/last-record
 when in forms mode.")

;;;
;;; Internal variables.

(defvar forms--file-buffer nil
  "Buffer which holds the file data")

(defvar forms--total-records 0
  "Total number of records in the data file.")

(defvar forms--current-record 0
  "Number of the record currently on the screen.")

(defvar forms-mode-map nil		; yes - this one is global
   "Keymap for form buffer.")

(defvar forms--markers nil
  "Field markers in the screen.")

(defvar forms--number-of-markers 0
  "Number of fields on screen.")

(defvar forms--the-record-list nil
   "List of strings of the current record, as parsed from the file.")

(defvar forms--search-regexp nil
  "Last regexp used by forms-search.")

(defvar forms--format nil
  "Formatting routine.")

(defvar forms--parser nil
  "Forms parser routine.")

(defvar forms--mode-setup nil
  "Internal - keeps track of forms-mode being set-up.")
(make-variable-buffer-local 'forms--mode-setup)

(defvar forms--new-record-filter nil
  "Internal - set if a new record filter has been defined.")

(defvar forms--modified-record-filter nil
  "Internal - set if a modified record filter has been defined.")

(defvar forms--dynamic-text nil
  "Internal - holds dynamic text to insert between fields.")

(defvar forms-fields nil
  "List with fields of the current forms. First field has number 1.")

;;;
;;; forms-mode
;;;
;;; This is not a simple major mode, as usual. Therefore, forms-mode
;;; takes an optional argument 'primary' which is used for the initial
;;; set-up. Normal use would leave 'primary' to nil.
;;;
;;; A global buffer-local variable 'forms--mode-setup' has the same effect
;;; but makes it possible to auto-invoke forms-mode using find-file.
;;;
;;; Note: although it seems logical to have (make-local-variable) executed
;;; where the variable is first needed, I deliberately placed all calls
;;; in the forms-mode function.

(defun forms-mode (&optional primary)
  "Major mode to visit files in a field-structured manner using a form.

 Commands (prefix with C-c if not in read-only mode):
 \\{forms-mode-map}"

  (interactive)				; no - 'primary' is not prefix arg

  ;; Primary set-up: evaluate buffer and check if the mandatory
  ;; variables have been set.
  (if (or primary (not forms--mode-setup))
      (progn
	(kill-all-local-variables)

	;; make mandatory variables
	(make-local-variable 'forms-file)
	(make-local-variable 'forms-number-of-fields)
	(make-local-variable 'forms-format-list)

	;; make optional variables
	(make-local-variable 'forms-field-sep)
        (make-local-variable 'forms-read-only)
        (make-local-variable 'forms-multi-line)
	(make-local-variable 'forms-forms-scroll)
	(make-local-variable 'forms-forms-jump)
	(fmakunbound 'forms-new-record-filter)

	;; eval the buffer, should set variables
	(eval-current-buffer)

	;; check if the mandatory variables make sense.
	(or forms-file
	    (error "'forms-file' has not been set"))
	(or forms-number-of-fields
	    (error "'forms-number-of-fields' has not been set"))
	(or (> forms-number-of-fields 0)
	    (error "'forms-number-of-fields' must be > 0")
	(or (stringp forms-field-sep))
	    (error "'forms-field-sep' is not a string"))
	(if forms-multi-line
	    (if (and (stringp forms-multi-line)
		     (eq (length forms-multi-line) 1))
		(if (string= forms-multi-line forms-field-sep)
		    (error "'forms-multi-line' is equal to 'forms-field-sep'"))
	      (error "'forms-multi-line' must be nil or a one-character string")))

	;; validate and process forms-format-list
	(make-local-variable 'forms--number-of-markers)
	(make-local-variable 'forms--markers)
	(forms--process-format-list)

	;; build the formatter and parser
	(make-local-variable 'forms--format)
	(forms--make-format)
	(make-local-variable 'forms--parser)
	(forms--make-parser)

	;; check if record filters are defined
	(make-local-variable 'forms--new-record-filter)
	(setq forms--new-record-filter
	      (cond
	       ((fboundp 'forms-new-record-filter)
		(symbol-function 'forms-new-record-filter))
	       ((and (boundp 'forms-new-record-filter)
		     (fboundp forms-new-record-filter))
		forms-new-record-filter)))
	(fmakunbound 'forms-new-record-filter)
	(make-local-variable 'forms--modified-record-filter)
	(setq forms--modified-record-filter
	      (cond
	       ((fboundp 'forms-modified-record-filter)
		(symbol-function 'forms-modified-record-filter))
	       ((and (boundp 'forms-modified-record-filter)
		     (fboundp forms-modified-record-filter))
		forms-modified-record-filter)))
	(fmakunbound 'forms-modified-record-filter)

	;; dynamic text support
	(make-local-variable 'forms--dynamic-text)
	(make-local-variable 'forms-fields)

	;; prepare this buffer for further processing
	(setq buffer-read-only nil)

	;; prevent accidental overwrite of the control file and autosave
	(setq buffer-file-name nil)
	(auto-save-mode nil)

	;; and clean it
	(erase-buffer)))

  ;; make local variables
  (make-local-variable 'forms--file-buffer)
  (make-local-variable 'forms--total-records)
  (make-local-variable 'forms--current-record)
  (make-local-variable 'forms--the-record-list)
  (make-local-variable 'forms--search-rexexp)

  ;; A bug in the current Emacs release prevents a keymap
  ;; which is buffer-local from being used by 'describe-mode'.
  ;; Hence we'll leave it global.
  ;;(make-local-variable 'forms-mode-map)
  (if forms-mode-map			; already defined
      nil
    (setq forms-mode-map (make-keymap))
    (forms--mode-commands forms-mode-map)
    (forms--change-commands))

  ;; find the data file
  (setq forms--file-buffer (find-file-noselect forms-file))

  ;; count the number of records, and set see if it may be modified
  (let (ro)
    (setq forms--total-records
	  (save-excursion
	    (set-buffer forms--file-buffer)
	    (bury-buffer (current-buffer))
	    (setq ro buffer-read-only)
	    (count-lines (point-min) (point-max))))
    (if ro
	(setq forms-read-only t)))

  ;; set the major mode indicator
  (setq major-mode 'forms-mode)
  (setq mode-name "Forms")
  (make-local-variable 'minor-mode-alist) ; needed?
  (forms--set-minor-mode)
  (forms--set-keymaps)

  (set-buffer-modified-p nil)

  ;; We have our own revert function - use it
  (make-local-variable 'revert-buffer-function)
  (setq revert-buffer-function 'forms-revert-buffer)

  ;; setup the first (or current) record to show
  (if (< forms--current-record 1)
      (setq forms--current-record 1))
  (forms-jump-record forms--current-record)

  ;; user customising
  (run-hooks 'forms-mode-hooks)

  ;; be helpful
  (forms--help)

  ;; initialization done
  (setq forms--mode-setup t))

;;;
;;; forms-process-format-list
;;;
;;; Validates forms-format-list.
;;;
;;; Sets forms--number-of-markers and forms--markers.

(defun forms--process-format-list ()
  "Validate forms-format-list and set some global variables."

  (forms--debug "forms-forms-list before 1st pass:\n"
		'forms-format-list)

  ;; it must be non-nil
  (or forms-format-list
      (error "'forms-format-list' has not been set"))
  ;; it must be a list ...
  (or (listp forms-format-list)
      (error "'forms-format-list' is not a list"))

  (setq forms--number-of-markers 0)

  (let ((the-list forms-format-list)	; the list of format elements
	(this-item 0)			; element in list
	(field-num 0))			; highest field number

    (setq forms-format-list nil)	; gonna rebuild

    (while the-list

      (let ((el (car-safe the-list))
	    (rem (cdr-safe the-list)))

	;; if it is a symbol, eval it first
	(if (and (symbolp el)
		 (boundp el))
	    (setq el (eval el)))

	(cond

	 ;; try string ...
	 ((stringp el))			; string is OK

	 ;; try numeric ...
	 ((numberp el)

	  (if (or (<= el 0)
		  (> el forms-number-of-fields))
	      (error
	       "Forms error: field number %d out of range 1..%d"
	       el forms-number-of-fields))

	  (setq forms--number-of-markers (1+ forms--number-of-markers))
	  (if (> el field-num)
	      (setq field-num el)))

	 ;; try function
	 ((listp el)
	  (or (fboundp (car-safe el))
	      (error
	       "Forms error: not a function: %s"
	       (prin1-to-string (car-safe el)))))

	 ;; else
	 (t
	  (error "Invalid element in 'forms-format-list': %s"
		 (prin1-to-string el))))

	;; advance to next element of the list
	(setq the-list rem)
	(setq forms-format-list
	      (append forms-format-list (list el) nil)))))

  (forms--debug "forms-forms-list after 1st pass:\n"
		'forms-format-list)

  ;; concat adjacent strings
  (setq forms-format-list (forms--concat-adjacent forms-format-list))

  (forms--debug "forms-forms-list after 2nd pass:\n"
		'forms-format-list
		'forms--number-of-markers)

  (setq forms--markers (make-vector forms--number-of-markers nil)))


;;;
;;; Build the format routine from forms-format-list.
;;;
;;; The format routine (forms--format) will look like
;;;
;;; (lambda (arg)
;;;   (setq forms--dynamic-text nil)
;;;   ;;  "text: "
;;;   (insert "text: ")
;;;   ;;  6
;;;   (aset forms--markers 0 (point-marker))
;;;   (insert (elt arg 5))
;;;   ;;  "\nmore text: "
;;;   (insert "\nmore text: ")
;;;   ;;  (tocol 40)
;;;   (let ((the-dyntext (tocol 40)))
;;;     (insert the-dyntext)
;;;     (setq forms--dynamic-text (append forms--dynamic-text
;;;					  (list the-dyntext))))
;;;   ;;  9
;;;   (aset forms--markers 1 (point-marker))
;;;   (insert (elt arg 8))
;;;
;;;   ... )
;;;

(defun forms--make-format ()
  "Generate format function for forms"
  (setq forms--format (forms--format-maker forms-format-list))
  (forms--debug 'forms--format))

(defun forms--format-maker (the-format-list)
  "Returns the parser function for forms"
  (let ((the-marker 0))
    (` (lambda (arg)
	 (setq forms--dynamic-text nil)
	 (,@ (apply 'append
		    (mapcar 'forms--make-format-elt the-format-list)))))))

(defun forms--make-format-elt (el)
  (cond ((stringp el)
	 (` ((insert (, el)))))
	((numberp el)
	 (prog1
	     (` ((aset forms--markers (, the-marker) (point-marker))
		 (insert (elt arg (, (1- el))))))
	   (setq the-marker (1+ the-marker))))
	((listp el)
	 (prog1
	     (` ((let ((the-dyntext (, el)))
		   (insert the-dyntext)
		   (setq forms--dynamic-text (append forms--dynamic-text
						     (list the-dyntext)))))
		)))
	))


(defun forms--concat-adjacent (the-list)
  "Concatenate adjacent strings in the-list and return the resulting list"
  (if (consp the-list)
      (let ((the-rest (forms--concat-adjacent (cdr the-list))))
	(if (and (stringp (car the-list)) (stringp (car the-rest)))
	    (cons (concat (car the-list) (car the-rest))
		  (cdr the-rest))
	    (cons (car the-list) the-rest)))
      the-list))
;;;
;;; forms--make-parser.
;;;
;;; Generate parse routine from forms-format-list.
;;;
;;; The parse routine (forms--parser) will look like (give or take
;;; a few " " .
;;;
;;; (lambda nil
;;;   (let (here)
;;;     (goto-char (point-min))
;;;
;;;	;;  "text: "
;;;     (if (not (looking-at "text: "))
;;; 	    (error "Parse error: cannot find \"text: \""))
;;;     (forward-char 6)	; past "text: "
;;;
;;;     ;;  6
;;;	;;  "\nmore text: "
;;;     (setq here (point))
;;;     (if (not (search-forward "\nmore text: " nil t nil))
;;; 	    (error "Parse error: cannot find \"\\nmore text: \""))
;;;     (aset the-recordv 5 (buffer-substring here (- (point) 12)))
;;;
;;;	;;  (tocol 40)
;;;	(let ((the-dyntext (car-safe forms--dynamic-text)))
;;;	  (if (not (looking-at (regexp-quote the-dyntext)))
;;;	      (error "Parse error: not looking at \"%s\"" the-dyntext))
;;;	  (forward-char (length the-dyntext))
;;;	  (setq forms--dynamic-text (cdr-safe forms--dynamic-text)))
;;;     ...
;;;     ;; final flush (due to terminator sentinel, see below)
;;;	(aset the-recordv 7 (buffer-substring (point) (point-max)))
;;;

(defun forms--make-parser ()
  "Generate parser function for forms"
  (setq forms--parser (forms--parser-maker forms-format-list))
  (forms--debug 'forms--parser))

(defun forms--parser-maker (the-format-list)
  "Returns the parser function for forms"
  (let ((the-field nil)
	(seen-text nil)
	the--format-list)
    ;; add a terminator sentinel
    (setq the--format-list (append the-format-list (list nil)))
    (` (lambda nil
	 (let (here)
	   (goto-char (point-min))
	 (,@ (apply 'append
		    (mapcar 'forms--make-parser-elt the--format-list))))))))

(defun forms--make-parser-elt (el)
  (cond
   ((stringp el)
    (prog1
	(if the-field
	    (` ((setq here (point))
		(if (not (search-forward (, el) nil t nil))
		    (error "Parse error: cannot find \"%s\"" (, el)))
		(aset the-recordv (, (1- the-field))
		      (buffer-substring here
					(- (point) (, (length el)))))))
	  (` ((if (not (looking-at (, (regexp-quote el))))
		  (error "Parse error: not looking at \"%s\"" (, el)))
	      (forward-char (, (length el))))))
      (setq seen-text t)
      (setq the-field nil)))
   ((numberp el)
    (if the-field
	(error "Cannot parse adjacent fields %d and %d"
	       the-field el)
      (setq the-field el)
      nil))
   ((null el)
    (if the-field
	(` ((aset the-recordv (, (1- the-field))
		  (buffer-substring (point) (point-max)))))))
   ((listp el)
    (prog1
	(if the-field
	    (` ((let ((here (point))
		      (the-dyntext (car-safe forms--dynamic-text)))
		  (if (not (search-forward the-dyntext nil t nil))
		      (error "Parse error: cannot find \"%s\"" the-dyntext))
		  (aset the-recordv (, (1- the-field))
			(buffer-substring here
					  (- (point) (length the-dyntext))))
		  (setq forms--dynamic-text (cdr-safe forms--dynamic-text)))))
	  (` ((let ((the-dyntext (car-safe forms--dynamic-text)))
		(if (not (looking-at (regexp-quote the-dyntext)))
		    (error "Parse error: not looking at \"%s\"" the-dyntext))
		(forward-char (length the-dyntext))
		(setq forms--dynamic-text (cdr-safe forms--dynamic-text))))))
      (setq seen-text t)
      (setq the-field nil)))
   ))
;;;

(defun forms--set-minor-mode ()
  (setq minor-mode-alist
	(if forms-read-only
	    " View"
	  nil)))

(defun forms--set-keymaps ()
  "Set the keymaps used in this mode."

  (if forms-read-only
      (use-local-map forms-mode-map)
    (use-local-map (make-sparse-keymap))
    (define-key (current-local-map) "\C-c" forms-mode-map)
    (define-key (current-local-map) "\t"   'forms-next-field)))

(defun forms--mode-commands (map)
  "Fill map with all commands."
  (define-key map "\t" 'forms-next-field)
  (define-key map " " 'forms-next-record)
  (define-key map "d" 'forms-delete-record)
  (define-key map "e" 'forms-edit-mode)
  (define-key map "i" 'forms-insert-record)
  (define-key map "j" 'forms-jump-record)
  (define-key map "n" 'forms-next-record)
  (define-key map "p" 'forms-prev-record)
  (define-key map "q" 'forms-exit)
  (define-key map "s" 'forms-search)
  (define-key map "v" 'forms-view-mode)
  (define-key map "x" 'forms-exit-no-save)
  (define-key map "<" 'forms-first-record)
  (define-key map ">" 'forms-last-record)
  (define-key map "?" 'describe-mode)
  (define-key map "\177" 'forms-prev-record)
 ;  (define-key map "\C-c" map)
  (define-key map "\e" 'ESC-prefix)
  (define-key map "\C-x" ctl-x-map)
  (define-key map "\C-u" 'universal-argument)
  (define-key map "\C-h" help-map)
  )
;;;
;;; Changed functions
;;;
;;; Emacs (as of 18.55) lacks the functionality of buffer-local
;;; funtions. Therefore we save the original meaning of some handy
;;; functions, and replace them with a wrapper.

(defun forms--change-commands ()
  "Localize some commands."
  ;;
  ;; scroll-down -> forms-prev-record
  ;;
  (if (fboundp 'forms--scroll-down)
      nil
    (fset 'forms--scroll-down (symbol-function 'scroll-down))
    (fset 'scroll-down
	  '(lambda (&optional arg)
	     (interactive "P")
	     (if (and forms--mode-setup
		      forms-forms-scroll)
		 (forms-prev-record arg)
	       (forms--scroll-down arg)))))
  ;;
  ;; scroll-up -> forms-next-record
  ;;
  (if (fboundp 'forms--scroll-up)
      nil
    (fset 'forms--scroll-up   (symbol-function 'scroll-up))
    (fset 'scroll-up
	  '(lambda (&optional arg)
	     (interactive "P")
	     (if (and forms--mode-setup
		      forms-forms-scroll)
		 (forms-next-record arg)
	       (forms--scroll-up arg)))))
  ;;
  ;; beginning-of-buffer -> forms-first-record
  ;;
  (if (fboundp 'forms--beginning-of-buffer)
      nil
    (fset 'forms--beginning-of-buffer (symbol-function 'beginning-of-buffer))
    (fset 'beginning-of-buffer
	  '(lambda ()
	     (interactive)
	     (if (and forms--mode-setup
		      forms-forms-jump)
		 (forms-first-record)
	       (forms--beginning-of-buffer)))))
  ;;
  ;; end-of-buffer -> forms-end-record
  ;;
  (if (fboundp 'forms--end-of-buffer)
      nil
    (fset 'forms--end-of-buffer (symbol-function 'end-of-buffer))
    (fset 'end-of-buffer
	  '(lambda ()
	     (interactive)
	     (if (and forms--mode-setup
		      forms-forms-jump)
		 (forms-last-record)
	       (forms--end-of-buffer)))))
  ;;
  ;; save-buffer -> forms--save-buffer
  ;;
  (if (fboundp 'forms--save-buffer)
      nil
    (fset 'forms--save-buffer (symbol-function 'save-buffer))
    (fset 'save-buffer
	  '(lambda (&optional arg)
	     (interactive "p")
	     (if forms--mode-setup
		 (progn
		   (forms--checkmod)
		   (save-excursion
		     (set-buffer forms--file-buffer)
		     (forms--save-buffer arg)))
	       (forms--save-buffer arg)))))
  ;;
  )

(defun forms--help ()
  "Initial help."
  ;; We should use
  ;;(message (substitute-command-keys (concat
  ;;"\\[forms-next-record]:next"
  ;;"   \\[forms-prev-record]:prev"
  ;;"   \\[forms-first-record]:first"
  ;;"   \\[forms-last-record]:last"
  ;;"   \\[describe-mode]:help"
  ;;"   \\[forms-exit]:exit")))
  ;; but it's too slow ....
  (if forms-read-only
      (message "SPC:next   DEL:prev   <:first   >:last   ?:help   q:exit")
    (message "C-c n:next   C-c p:prev   C-c <:first   C-c >:last   C-c ?:help   C-c q:exit")))

(defun forms--trans (subj arg rep)
  "Translate in SUBJ all chars ARG into char REP. ARG and REP should
 be single-char strings."
  (let ((i 0)
	(x (length subj))
	(re (regexp-quote arg))
	(k (string-to-char rep)))
    (while (setq i (string-match re subj i))
      (aset subj i k)
      (setq i (1+ i)))))

(defun forms--exit (query &optional save)
  (let ((buf (buffer-name forms--file-buffer)))
    (forms--checkmod)
    (if (and save
	     (buffer-modified-p forms--file-buffer))
	(save-excursion
	  (set-buffer forms--file-buffer)
	  (save-buffer)))
    (save-excursion
      (set-buffer forms--file-buffer)
      (delete-auto-save-file-if-necessary)
      (kill-buffer (current-buffer)))
    (if (get-buffer buf)	; not killed???
      (if save
	  (progn
	    (beep)
	    (message "Problem saving buffers?")))
      (delete-auto-save-file-if-necessary)
      (kill-buffer (current-buffer)))))

(defun forms--get-record ()
  "Fetch the current record from the file buffer."
  ;;
  ;; This function is executed in the context of the forms--file-buffer.
  ;;
  (or (bolp)
      (beginning-of-line nil))
  (let ((here (point)))
    (prog2
     (end-of-line)
     (buffer-substring here (point))
     (goto-char here))))

(defun forms--show-record (the-record)
  "Format THE-RECORD according to forms-format-list,
 and display it in the current buffer."

  ;; split the-record
  (let (the-result
	(start-pos 0)
	found-pos
	(field-sep-length (length forms-field-sep)))
    (if forms-multi-line
	(forms--trans the-record forms-multi-line "\n"))
    ;; add an extra separator (makes splitting easy)
    (setq the-record (concat the-record forms-field-sep))
    (while (setq found-pos (string-match forms-field-sep the-record start-pos))
      (let ((ent (substring the-record start-pos found-pos)))
	(setq the-result
	      (append the-result (list ent)))
	(setq start-pos (+ field-sep-length found-pos))))
    (setq forms--the-record-list the-result))

  (setq buffer-read-only nil)
  (erase-buffer)

  ;; verify the number of fields, extend forms--the-record-list if needed
  (if (= (length forms--the-record-list) forms-number-of-fields)
      nil
    (beep)
    (message "Record has %d fields instead of %d."
	     (length forms--the-record-list) forms-number-of-fields)
    (if (< (length forms--the-record-list) forms-number-of-fields)
	(setq forms--the-record-list
	      (append forms--the-record-list
		      (make-list
		       (- forms-number-of-fields
			  (length forms--the-record-list))
		       "")))))

  ;; call the formatter function
  (setq forms-fields (append (list nil) forms--the-record-list nil))
  (funcall forms--format forms--the-record-list)

  ;; prepare
  (goto-char (point-min))
  (set-buffer-modified-p nil)
  (setq buffer-read-only forms-read-only)
  (setq mode-line-process
	(concat " " forms--current-record "/" forms--total-records)))

(defun forms--parse-form ()
  "Parse contents of form into list of strings."
  ;; The contents of the form are parsed, and a new list of strings
  ;; is constructed.
  ;; A vector with the strings from the original record is
  ;; constructed, which is updated with the new contents. Therefore
  ;; fields which were not in the form are not modified.
  ;; Finally, the vector is transformed into a list for further processing.

  (let (the-recordv)

    ;; build the vector
    (setq the-recordv (vconcat forms--the-record-list))

    ;; parse the form and update the vector
    (let ((forms--dynamic-text forms--dynamic-text))
      (funcall forms--parser))

    (if forms--modified-record-filter
	;; As a service to the user, we add a zeroth element so she
	;; can use the same indices as in the forms definition.
	(let ((the-fields (vconcat [nil] the-recordv)))
	  (setq the-fields (funcall forms--modified-record-filter the-fields))
	  (cdr (append the-fields nil)))

      ;; transform to a list and return
      (append the-recordv nil))))

(defun forms--update ()
  "Update current record with contents of form. As a side effect: sets
forms--the-record-list ."
  (if forms-read-only
      (progn
	(message "Read-only buffer!")
	(beep))

    (let (the-record)
      ;; build new record
      (setq forms--the-record-list (forms--parse-form))
      (setq the-record
	    (mapconcat 'identity forms--the-record-list forms-field-sep))

      ;; handle multi-line fields, if allowed
      (if forms-multi-line
	  (forms--trans the-record "\n" forms-multi-line))

      ;; a final sanity check before updating
      (if (string-match "\n" the-record)
	  (progn
	    (message "Multi-line fields in this record - update refused!")
	    (beep))

	(save-excursion
	  (set-buffer forms--file-buffer)
	  ;; Insert something before kill-line is called. See kill-line
	  ;; doc. Bugfix provided by Ignatios Souvatzis.
	  (insert "*")
	  (beginning-of-line)
	  (kill-line nil)
	  (insert the-record)
	  (beginning-of-line))))))

(defun forms--checkmod ()
  "Check if this form has been modified, and call forms--update if so."
  (if (buffer-modified-p nil)
      (let ((here (point)))
	(forms--update)
	(set-buffer-modified-p nil)
	(goto-char here))))

;;;
;;; Start and exit
(defun forms-find-file (fn)
  "Visit file FN in forms mode"
  (interactive "fForms file: ")
  (find-file-read-only fn)
  (or forms--mode-setup (forms-mode t)))

(defun forms-find-file-other-window (fn)
  "Visit file FN in form mode in other window"
  (interactive "fFbrowse file in other window: ")
  (find-file-other-window fn)
  (eval-current-buffer)
  (or forms--mode-setup (forms-mode t)))

(defun forms-exit (query)
  "Normal exit. Modified buffers are saved."
  (interactive "P")
  (forms--exit query t))

(defun forms-exit-no-save (query)
  "Exit without saving buffers."
  (interactive "P")
  (forms--exit query nil))

;;;
;;; Navigating commands

(defun forms-next-record (arg)
  "Advance to the ARGth following record."
  (interactive "P")
  (forms-jump-record (+ forms--current-record (prefix-numeric-value arg)) t))

(defun forms-prev-record (arg)
  "Advance to the ARGth previous record."
  (interactive "P")
  (forms-jump-record (- forms--current-record (prefix-numeric-value arg)) t))

(defun forms-jump-record (arg &optional relative)
  "Jump to a random record."
  (interactive "NRecord number: ")

  ;; verify that the record number is within range
  (if (or (> arg forms--total-records)
	  (<= arg 0))
    (progn
      (beep)
      ;; don't give the message if just paging
      (if (not relative)
	  (message "Record number %d out of range 1..%d"
		   arg forms--total-records))
      )

    ;; flush
    (forms--checkmod)

    ;; calculate displacement
    (let ((disp (- arg forms--current-record))
	  (cur forms--current-record))

      ;; forms--show-record needs it now
      (setq forms--current-record arg)

      ;; get the record and show it
      (forms--show-record
       (save-excursion
	 (set-buffer forms--file-buffer)
	 (beginning-of-line)

	 ;; move, and adjust the amount if needed (shouldn't happen)
	 (if relative
	     (if (zerop disp)
		 nil
	       (setq cur (+ cur disp (- (forward-line disp)))))
	   (setq cur (+ cur disp (- (goto-line arg)))))

	 (forms--get-record)))

      ;; this shouldn't happen
      (if (/= forms--current-record cur)
	  (progn
	    (setq forms--current-record cur)
	    (beep)
	    (message "Stuck at record %d." cur))))))

(defun forms-first-record ()
  "Jump to first record."
  (interactive)
  (forms-jump-record 1))

(defun forms-last-record ()
  "Jump to last record. As a side effect: re-calculates the number
 of records in the data file."
  (interactive)
  (let
      ((numrec
	(save-excursion
	  (set-buffer forms--file-buffer)
	  (count-lines (point-min) (point-max)))))
    (if (= numrec forms--total-records)
	nil
      (beep)
      (setq forms--total-records numrec)
      (message "Number of records reset to %d." forms--total-records)))
  (forms-jump-record forms--total-records))

;;;
;;; Other commands
(defun forms-view-mode ()
  "Visit buffer read-only."
  (interactive)
  (if forms-read-only
      nil
    (forms--checkmod)			; sync
    (setq forms-read-only t)
    (forms-mode)))

(defun forms-edit-mode ()
  "Make form suitable for editing, if possible."
  (interactive)
  (let ((ro forms-read-only))
    (if (save-excursion
	  (set-buffer forms--file-buffer)
	  buffer-read-only)
	(progn
	  (setq forms-read-only t)
	  (message "No write access to \"%s\"" forms-file)
	  (beep))
      (setq forms-read-only nil))
    (if (equal ro forms-read-only)
	nil
      (forms-mode))))

;; Sample:
;; (defun my-new-record-filter (the-fields)
;;   ;; numbers are relative to 1
;;   (aset the-fields 4 (current-time-string))
;;   (aset the-fields 6 (user-login-name))
;;   the-list)
;; (setq forms-new-record-filter 'my-new-record-filter)

(defun forms-insert-record (arg)
  "Create a new record before the current one. With ARG: store the
 record after the current one.
 If a function forms-new-record-filter is defined, or forms-new-record-filter
 contains the name of a function, it is called to
 fill (some of) the fields with default values."
 ; The above doc is not true, but for documentary purposes only

  (interactive "P")

  (let ((ln (if arg (1+ forms--current-record) forms--current-record))
        the-list the-record)

    (forms--checkmod)
    (if forms--new-record-filter
	;; As a service to the user, we add a zeroth element so she
	;; can use the same indices as in the forms definition.
	(let ((the-fields (make-vector (1+ forms-number-of-fields) "")))
	  (setq the-fields (funcall forms--new-record-filter the-fields))
	  (setq the-list (cdr (append the-fields nil))))
      (setq the-list (make-list forms-number-of-fields "")))

    (setq the-record
	  (mapconcat
	  'identity
	  the-list
	  forms-field-sep))

    (save-excursion
      (set-buffer forms--file-buffer)
      (goto-line ln)
      (open-line 1)
      (insert the-record)
      (beginning-of-line))

    (setq forms--current-record ln))

  (setq forms--total-records (1+ forms--total-records))
  (forms-jump-record forms--current-record))

(defun forms-delete-record (arg)
  "Deletes a record. With ARG: don't ask."
  (interactive "P")
  (forms--checkmod)
  (if (or arg
	  (y-or-n-p "Really delete this record? "))
      (let ((ln forms--current-record))
	(save-excursion
	  (set-buffer forms--file-buffer)
	  (goto-line ln)
	  (kill-line 1))
	(setq forms--total-records (1- forms--total-records))
	(if (> forms--current-record forms--total-records)
	    (setq forms--current-record forms--total-records))
	(forms-jump-record forms--current-record)))
  (message ""))

(defun forms-search (regexp)
  "Search REGEXP in file buffer."
  (interactive
   (list (read-string (concat "Search for"
				  (if forms--search-regexp
				   (concat " ("
					   forms--search-regexp
					   ")"))
				  ": "))))
  (if (equal "" regexp)
      (setq regexp forms--search-regexp))
  (forms--checkmod)

  (let (the-line the-record here
		 (fld-sep forms-field-sep))
    (if (save-excursion
	  (set-buffer forms--file-buffer)
	  (setq here (point))
	  (end-of-line)
	  (if (null (re-search-forward regexp nil t))
	      (progn
		(goto-char here)
		(message (concat "\"" regexp "\" not found."))
		nil)
	    (setq the-record (forms--get-record))
	    (setq the-line (1+ (count-lines (point-min) (point))))))
	(progn
	  (setq forms--current-record the-line)
	  (forms--show-record the-record)
	  (re-search-forward regexp nil t))))
  (setq forms--search-regexp regexp))

(defun forms-revert-buffer (&optional arg noconfirm)
  "Reverts current form to un-modified."
  (interactive "P")
  (if (or noconfirm
	  (yes-or-no-p "Revert form to unmodified? "))
      (progn
	(set-buffer-modified-p nil)
	(forms-jump-record forms--current-record))))

(defun forms-next-field (arg)
  "Jump to ARG-th next field."
  (interactive "p")

  (let ((i 0)
	(here (point))
	there
	(cnt 0))

    (if (zerop arg)
	(setq cnt 1)
      (setq cnt (+ cnt arg)))

    (if (catch 'done
	  (while (< i forms--number-of-markers)
	    (if (or (null (setq there (aref forms--markers i)))
		    (<= there here))
		nil
	      (if (<= (setq cnt (1- cnt)) 0)
		  (progn
		    (goto-char there)
		    (throw 'done t))))
	    (setq i (1+ i))))
	nil
      (goto-char (aref forms--markers 0)))))

;;;
;;; Special service
;;;
(defun forms-enumerate (the-fields)
  "Take a quoted list of symbols, and set their values to the numbers
1, 2 and so on. Returns the higest number.

Usage: (setq forms-number-of-fields
             (forms-enumerate
              '(field1 field2 field2 ...)))"

  (let ((the-index 0))
    (while the-fields
      (setq the-index (1+ the-index))
      (let ((el (car-safe the-fields)))
	(setq the-fields (cdr-safe the-fields))
	(set el the-index)))
    the-index))

;;;
;;; Debugging
;;;
(defvar forms--debug nil
  "*Enables forms-mode debugging if not nil.")

(defun forms--debug (&rest args)
  "Internal - debugging routine"
  (if forms--debug
      (let ((ret nil))
	(while args
	  (let ((el (car-safe args)))
	    (setq args (cdr-safe args))
	    (if (stringp el)
		(setq ret (concat ret el))
	      (setq ret (concat ret (prin1-to-string el) " = "))
	      (if (boundp el)
		  (let ((vel (eval el)))
		    (setq ret (concat ret (prin1-to-string vel) "\n")))
		(setq ret (concat ret "<unbound>" "\n")))
	      (if (fboundp el)
		  (setq ret (concat ret (prin1-to-string (symbol-function el))
				    "\n"))))))
	(save-excursion
	  (set-buffer (get-buffer-create "*forms-mode debug*"))
	  (goto-char (point-max))
	  (insert ret)))))

;;; Local Variables:
;;; eval: (headers)
;;; eval: (setq comment-start ";;; ")
;;; End:
author	Jim Blandy <jimb@redhat.com>
date	Mon, 24 May 1993 15:59:44 +0000 (1993-05-24)
parents	7fede845e304
children	994bb6dc9249