*** empty log message ***
[emacs.git] / lisp / forms.el
blob3690c7e9a4ad282e56789d1f8aa497b5e4c79c60
1 ;;; forms.el -- Forms Mode - A GNU Emacs Major Mode
2 ;;; SCCS Status : @(#)@ forms 1.2.7
3 ;;; Author : Johan Vromans
4 ;;; Created On : 1989
5 ;;; Last Modified By: Johan Vromans
6 ;;; Last Modified On: Mon Jul 1 14:13:20 1991
7 ;;; Update Count : 15
8 ;;; Status : OK
10 ;;; This file is part of GNU Emacs.
11 ;;; GNU Emacs is distributed in the hope that it will be useful,
12 ;;; but WITHOUT ANY WARRANTY. No author or distributor
13 ;;; accepts responsibility to anyone for the consequences of using it
14 ;;; or for whether it serves any particular purpose or works at all,
15 ;;; unless he says so in writing. Refer to the GNU Emacs General Public
16 ;;; License for full details.
18 ;;; Everyone is granted permission to copy, modify and redistribute
19 ;;; GNU Emacs, but only under the conditions described in the
20 ;;; GNU Emacs General Public License. A copy of this license is
21 ;;; supposed to have been given to you along with GNU Emacs so you
22 ;;; can know your rights and responsibilities.
23 ;;; If you don't have this copy, write to the Free Software
24 ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
25 ;;;
27 ;;; HISTORY
28 ;;; 1-Jul-1991 Johan Vromans
29 ;;; Normalized error messages.
30 ;;; 30-Jun-1991 Johan Vromans
31 ;;; Add support for forms-modified-record-filter.
32 ;;; Allow the filter functions to be the name of a function.
33 ;;; Fix: parse--format used forms--dynamic-text destructively.
34 ;;; Internally optimized the forms-format-list.
35 ;;; Added support for debugging.
36 ;;; Stripped duplicate documentation.
37 ;;;
38 ;;; 29-Jun-1991 Johan Vromans
39 ;;; Add support for functions and lisp symbols in forms-format-list.
40 ;;; Add function forms-enumerate.
42 (provide 'forms-mode)
44 ;;; Visit a file using a form.
45 ;;;
46 ;;; === Naming conventions
47 ;;;
48 ;;; The names of all variables and functions start with 'form-'.
49 ;;; Names which start with 'form--' are intended for internal use, and
50 ;;; should *NOT* be used from the outside.
51 ;;;
52 ;;; All variables are buffer-local, to enable multiple forms visits
53 ;;; simultaneously.
54 ;;; Variable 'forms--mode-setup' is local to *ALL* buffers, for it
55 ;;; controls if forms-mode has been enabled in a buffer.
56 ;;;
57 ;;; === How it works ===
58 ;;;
59 ;;; Forms mode means visiting a data file which is supposed to consist
60 ;;; of records each containing a number of fields. The records are
61 ;;; separated by a newline, the fields are separated by a user-defined
62 ;;; field separater (default: TAB).
63 ;;; When shown, a record is transferred to an emacs buffer and
64 ;;; presented using a user-defined form. One record is shown at a
65 ;;; time.
66 ;;;
67 ;;; Forms mode is a composite mode. It involves two files, and two
68 ;;; buffers.
69 ;;; The first file, called the control file, defines the name of the
70 ;;; data file and the forms format. This file buffer will be used to
71 ;;; present the forms.
72 ;;; The second file holds the actual data. The buffer of this file
73 ;;; will be buried, for it is never accessed directly.
74 ;;;
75 ;;; Forms mode is invoked using "forms-find-file control-file".
76 ;;; Alternativily forms-find-file-other-window can be used.
77 ;;;
78 ;;; You may also visit the control file, and switch to forms mode by hand
79 ;;; with M-x forms-mode .
80 ;;;
81 ;;; Automatic mode switching is supported, so you may use "find-file"
82 ;;; if you specify "-*- forms -*-" in the first line of the control file.
83 ;;;
84 ;;; The control file is visited, evaluated using
85 ;;; eval-current-buffer, and should set at least the following
86 ;;; variables:
87 ;;;
88 ;;; forms-file [string] the name of the data file.
89 ;;;
90 ;;; forms-number-of-fields [integer]
91 ;;; The number of fields in each record.
92 ;;;
93 ;;; forms-format-list [list] formatting instructions.
94 ;;;
95 ;;; The forms-format-list should be a list, each element containing
96 ;;;
97 ;;; - a string, e.g. "hello" (which is inserted \"as is\"),
98 ;;;
99 ;;; - an integer, denoting a field number. The contents of the field
100 ;;; are inserted at this point.
101 ;;; The first field has number one.
103 ;;; - a function call, e.g. (insert "text"). This function call is
104 ;;; dynamically evaluated and should return a string. It should *NOT*
105 ;;; have side-effects on the forms being constructed.
106 ;;; The current fields are available to the function in the variable
107 ;;; forms-fields, they should *NOT* be modified.
109 ;;; - a lisp symbol, that must evaluate to one of the above.
111 ;;; Optional variables which may be set in the control file:
113 ;;; forms-field-sep [string, default TAB]
114 ;;; The field separator used to separate the
115 ;;; fields in the data file. It may be a string.
117 ;;; forms-read-only [bool, default nil]
118 ;;; 't' means that the data file is visited read-only.
119 ;;; If no write access to the data file is
120 ;;; possible, read-only mode is enforced.
122 ;;; forms-multi-line [string, default "^K"]
123 ;;; If non-null the records of the data file may
124 ;;; contain fields which span multiple lines in
125 ;;; the form.
126 ;;; This variable denoted the separator character
127 ;;; to be used for this purpose. Upon display, all
128 ;;; occurrencies of this character are translated
129 ;;; to newlines. Upon storage they are translated
130 ;;; back to the separator.
132 ;;; forms-forms-scroll [bool, default t]
133 ;;; If non-nil: redefine scroll-up/down to perform
134 ;;; forms-next/prev-field if in forms mode.
136 ;;; forms-forms-jump [bool, default t]
137 ;;; If non-nil: redefine beginning/end-of-buffer
138 ;;; to performs forms-first/last-field if in
139 ;;; forms mode.
141 ;;; forms-new-record-filter [symbol, no default]
142 ;;; If defined: this should be the name of a
143 ;;; function that is called when a new
144 ;;; record is created. It can be used to fill in
145 ;;; the new record with default fields, for example.
146 ;;; Instead of the name of the function, it may
147 ;;; be the function itself.
149 ;;; forms-modified-record-filter [symbol, no default]
150 ;;; If defined: this should be the name of a
151 ;;; function that is called when a record has
152 ;;; been modified. It is called after the fields
153 ;;; are parsed. It can be used to register
154 ;;; modification dates, for example.
155 ;;; Instead of the name of the function, it may
156 ;;; be the function itself.
158 ;;; After evaluating the control file, its buffer is cleared and used
159 ;;; for further processing.
160 ;;; The data file (as designated by "forms-file") is visited in a buffer
161 ;;; (forms--file-buffer) which will not normally be shown.
162 ;;; Great malfunctioning may be expected if this file/buffer is modified
163 ;;; outside of this package while it's being visited!
165 ;;; A record from the data file is transferred from the data file,
166 ;;; split into fields (into forms--the-record-list), and displayed using
167 ;;; the specs in forms-format-list.
168 ;;; A format routine 'forms--format' is built upon startup to format
169 ;;; the records.
171 ;;; When a form is changed the record is updated as soon as this form
172 ;;; is left. The contents of the form are parsed using forms-format-list,
173 ;;; and the fields which are deduced from the form are modified. So,
174 ;;; fields not shown on the forms retain their origional values.
175 ;;; The newly formed record and replaces the contents of the
176 ;;; old record in forms--file-buffer.
177 ;;; A parse routine 'forms--parser' is built upon startup to parse
178 ;;; the records.
180 ;;; Two exit functions exist: forms-exit (which saves) and forms-exit-no-save
181 ;;; (which doesn't). However, if forms-exit-no-save is executed and the file
182 ;;; buffer has been modified, emacs will ask questions.
184 ;;; Other functions are:
186 ;;; paging (forward, backward) by record
187 ;;; jumping (first, last, random number)
188 ;;; searching
189 ;;; creating and deleting records
190 ;;; reverting the form (NOT the file buffer)
191 ;;; switching edit <-> view mode v.v.
192 ;;; jumping from field to field
194 ;;; As an documented side-effect: jumping to the last record in the
195 ;;; file (using forms-last-record) will adjust forms--total-records if
196 ;;; needed.
198 ;;; Commands and keymaps:
200 ;;; A local keymap 'forms-mode-map' is used in the forms buffer.
201 ;;; As conventional, this map can be accessed with C-c prefix.
202 ;;; In read-only mode, the C-c prefix must be omitted.
204 ;;; Default bindings:
206 ;;; \C-c forms-mode-map
207 ;;; TAB forms-next-field
208 ;;; SPC forms-next-record
209 ;;; < forms-first-record
210 ;;; > forms-last-record
211 ;;; ? describe-mode
212 ;;; d forms-delete-record
213 ;;; e forms-edit-mode
214 ;;; i forms-insert-record
215 ;;; j forms-jump-record
216 ;;; n forms-next-record
217 ;;; p forms-prev-record
218 ;;; q forms-exit
219 ;;; s forms-search
220 ;;; v forms-view-mode
221 ;;; x forms-exit-no-save
222 ;;; DEL forms-prev-record
224 ;;; Standard functions scroll-up, scroll-down, beginning-of-buffer and
225 ;;; end-of-buffer are wrapped with re-definitions, which map them to
226 ;;; next/prev record and first/last record.
227 ;;; Buffer-local variables forms-forms-scroll and forms-forms-jump
228 ;;; may be used to control these redefinitions.
230 ;;; Function save-buffer is also wrapped to perform a sensible action.
231 ;;; A revert-file-hook is defined to revert a forms to original.
233 ;;; For convenience, TAB is always bound to forms-next-field, so you
234 ;;; don't need the C-c prefix for this command.
235 ;;;\f
236 ;;; Global variables and constants
238 (defconst forms-version "1.2.7"
239 "Version of forms-mode implementation")
241 (defvar forms-forms-scrolls t
242 "If non-null: redefine scroll-up/down to be used with forms-mode.")
244 (defvar forms-forms-jumps t
245 "If non-null: redefine beginning/end-of-buffer to be used with forms-mode.")
247 (defvar forms-mode-hooks nil
248 "Hook functions to be run upon entering forms mode.")
249 ;;;\f
250 ;;; Mandatory variables - must be set by evaluating the control file
252 (defvar forms-file nil
253 "Name of the file holding the data.")
255 (defvar forms-format-list nil
256 "List of formatting specifications.")
258 (defvar forms-number-of-fields nil
259 "Number of fields per record.")
261 ;;;\f
262 ;;; Optional variables with default values
264 (defvar forms-field-sep "\t"
265 "Field separator character (default TAB)")
267 (defvar forms-read-only nil
268 "Read-only mode (defaults to the write access on the data file).")
270 (defvar forms-multi-line "\C-k"
271 "Character to separate multi-line fields (default ^K)")
273 (defvar forms-forms-scroll t
274 "Redefine scroll-up/down to perform forms-next/prev-record when in
275 forms mode.")
277 (defvar forms-forms-jump t
278 "Redefine beginning/end-of-buffer to perform forms-first/last-record
279 when in forms mode.")
281 ;;;\f
282 ;;; Internal variables.
284 (defvar forms--file-buffer nil
285 "Buffer which holds the file data")
287 (defvar forms--total-records 0
288 "Total number of records in the data file.")
290 (defvar forms--current-record 0
291 "Number of the record currently on the screen.")
293 (defvar forms-mode-map nil ; yes - this one is global
294 "Keymap for form buffer.")
296 (defvar forms--markers nil
297 "Field markers in the screen.")
299 (defvar forms--number-of-markers 0
300 "Number of fields on screen.")
302 (defvar forms--the-record-list nil
303 "List of strings of the current record, as parsed from the file.")
305 (defvar forms--search-regexp nil
306 "Last regexp used by forms-search.")
308 (defvar forms--format nil
309 "Formatting routine.")
311 (defvar forms--parser nil
312 "Forms parser routine.")
314 (defvar forms--mode-setup nil
315 "Internal - keeps track of forms-mode being set-up.")
316 (make-variable-buffer-local 'forms--mode-setup)
318 (defvar forms--new-record-filter nil
319 "Internal - set if a new record filter has been defined.")
321 (defvar forms--modified-record-filter nil
322 "Internal - set if a modified record filter has been defined.")
324 (defvar forms--dynamic-text nil
325 "Internal - holds dynamic text to insert between fields.")
327 (defvar forms-fields nil
328 "List with fields of the current forms. First field has number 1.")
330 ;;;\f
331 ;;; forms-mode
333 ;;; This is not a simple major mode, as usual. Therefore, forms-mode
334 ;;; takes an optional argument 'primary' which is used for the initial
335 ;;; set-up. Normal use would leave 'primary' to nil.
337 ;;; A global buffer-local variable 'forms--mode-setup' has the same effect
338 ;;; but makes it possible to auto-invoke forms-mode using find-file.
340 ;;; Note: although it seems logical to have (make-local-variable) executed
341 ;;; where the variable is first needed, I deliberately placed all calls
342 ;;; in the forms-mode function.
344 (defun forms-mode (&optional primary)
345 "Major mode to visit files in a field-structured manner using a form.
347 Commands (prefix with C-c if not in read-only mode):
348 \\{forms-mode-map}"
350 (interactive) ; no - 'primary' is not prefix arg
352 ;; Primary set-up: evaluate buffer and check if the mandatory
353 ;; variables have been set.
354 (if (or primary (not forms--mode-setup))
355 (progn
356 (kill-all-local-variables)
358 ;; make mandatory variables
359 (make-local-variable 'forms-file)
360 (make-local-variable 'forms-number-of-fields)
361 (make-local-variable 'forms-format-list)
363 ;; make optional variables
364 (make-local-variable 'forms-field-sep)
365 (make-local-variable 'forms-read-only)
366 (make-local-variable 'forms-multi-line)
367 (make-local-variable 'forms-forms-scroll)
368 (make-local-variable 'forms-forms-jump)
369 (fmakunbound 'forms-new-record-filter)
371 ;; eval the buffer, should set variables
372 (eval-current-buffer)
374 ;; check if the mandatory variables make sense.
375 (or forms-file
376 (error "'forms-file' has not been set"))
377 (or forms-number-of-fields
378 (error "'forms-number-of-fields' has not been set"))
379 (or (> forms-number-of-fields 0)
380 (error "'forms-number-of-fields' must be > 0")
381 (or (stringp forms-field-sep))
382 (error "'forms-field-sep' is not a string"))
383 (if forms-multi-line
384 (if (and (stringp forms-multi-line)
385 (eq (length forms-multi-line) 1))
386 (if (string= forms-multi-line forms-field-sep)
387 (error "'forms-multi-line' is equal to 'forms-field-sep'"))
388 (error "'forms-multi-line' must be nil or a one-character string")))
390 ;; validate and process forms-format-list
391 (make-local-variable 'forms--number-of-markers)
392 (make-local-variable 'forms--markers)
393 (forms--process-format-list)
395 ;; build the formatter and parser
396 (make-local-variable 'forms--format)
397 (forms--make-format)
398 (make-local-variable 'forms--parser)
399 (forms--make-parser)
401 ;; check if record filters are defined
402 (make-local-variable 'forms--new-record-filter)
403 (setq forms--new-record-filter
404 (cond
405 ((fboundp 'forms-new-record-filter)
406 (symbol-function 'forms-new-record-filter))
407 ((and (boundp 'forms-new-record-filter)
408 (fboundp forms-new-record-filter))
409 forms-new-record-filter)))
410 (fmakunbound 'forms-new-record-filter)
411 (make-local-variable 'forms--modified-record-filter)
412 (setq forms--modified-record-filter
413 (cond
414 ((fboundp 'forms-modified-record-filter)
415 (symbol-function 'forms-modified-record-filter))
416 ((and (boundp 'forms-modified-record-filter)
417 (fboundp forms-modified-record-filter))
418 forms-modified-record-filter)))
419 (fmakunbound 'forms-modified-record-filter)
421 ;; dynamic text support
422 (make-local-variable 'forms--dynamic-text)
423 (make-local-variable 'forms-fields)
425 ;; prepare this buffer for further processing
426 (setq buffer-read-only nil)
428 ;; prevent accidental overwrite of the control file and autosave
429 (setq buffer-file-name nil)
430 (auto-save-mode nil)
432 ;; and clean it
433 (erase-buffer)))
435 ;; make local variables
436 (make-local-variable 'forms--file-buffer)
437 (make-local-variable 'forms--total-records)
438 (make-local-variable 'forms--current-record)
439 (make-local-variable 'forms--the-record-list)
440 (make-local-variable 'forms--search-rexexp)
442 ;; A bug in the current Emacs release prevents a keymap
443 ;; which is buffer-local from being used by 'describe-mode'.
444 ;; Hence we'll leave it global.
445 ;;(make-local-variable 'forms-mode-map)
446 (if forms-mode-map ; already defined
448 (setq forms-mode-map (make-keymap))
449 (forms--mode-commands forms-mode-map)
450 (forms--change-commands))
452 ;; find the data file
453 (setq forms--file-buffer (find-file-noselect forms-file))
455 ;; count the number of records, and set see if it may be modified
456 (let (ro)
457 (setq forms--total-records
458 (save-excursion
459 (set-buffer forms--file-buffer)
460 (bury-buffer (current-buffer))
461 (setq ro buffer-read-only)
462 (count-lines (point-min) (point-max))))
463 (if ro
464 (setq forms-read-only t)))
466 ;; set the major mode indicator
467 (setq major-mode 'forms-mode)
468 (setq mode-name "Forms")
469 (make-local-variable 'minor-mode-alist) ; needed?
470 (forms--set-minor-mode)
471 (forms--set-keymaps)
473 (set-buffer-modified-p nil)
475 ;; We have our own revert function - use it
476 (make-local-variable 'revert-buffer-function)
477 (setq revert-buffer-function 'forms-revert-buffer)
479 ;; setup the first (or current) record to show
480 (if (< forms--current-record 1)
481 (setq forms--current-record 1))
482 (forms-jump-record forms--current-record)
484 ;; user customising
485 (run-hooks 'forms-mode-hooks)
487 ;; be helpful
488 (forms--help)
490 ;; initialization done
491 (setq forms--mode-setup t))
493 ;;;\f
494 ;;; forms-process-format-list
496 ;;; Validates forms-format-list.
498 ;;; Sets forms--number-of-markers and forms--markers.
500 (defun forms--process-format-list ()
501 "Validate forms-format-list and set some global variables."
503 (forms--debug "forms-forms-list before 1st pass:\n"
504 'forms-format-list)
506 ;; it must be non-nil
507 (or forms-format-list
508 (error "'forms-format-list' has not been set"))
509 ;; it must be a list ...
510 (or (listp forms-format-list)
511 (error "'forms-format-list' is not a list"))
513 (setq forms--number-of-markers 0)
515 (let ((the-list forms-format-list) ; the list of format elements
516 (this-item 0) ; element in list
517 (field-num 0)) ; highest field number
519 (setq forms-format-list nil) ; gonna rebuild
521 (while the-list
523 (let ((el (car-safe the-list))
524 (rem (cdr-safe the-list)))
526 ;; if it is a symbol, eval it first
527 (if (and (symbolp el)
528 (boundp el))
529 (setq el (eval el)))
531 (cond
533 ;; try string ...
534 ((stringp el)) ; string is OK
536 ;; try numeric ...
537 ((numberp el)
539 (if (or (<= el 0)
540 (> el forms-number-of-fields))
541 (error
542 "Forms error: field number %d out of range 1..%d"
543 el forms-number-of-fields))
545 (setq forms--number-of-markers (1+ forms--number-of-markers))
546 (if (> el field-num)
547 (setq field-num el)))
549 ;; try function
550 ((listp el)
551 (or (fboundp (car-safe el))
552 (error
553 "Forms error: not a function: %s"
554 (prin1-to-string (car-safe el)))))
556 ;; else
558 (error "Invalid element in 'forms-format-list': %s"
559 (prin1-to-string el))))
561 ;; advance to next element of the list
562 (setq the-list rem)
563 (setq forms-format-list
564 (append forms-format-list (list el) nil)))))
566 (forms--debug "forms-forms-list after 1st pass:\n"
567 'forms-format-list)
569 ;; concat adjacent strings
570 (setq forms-format-list (forms--concat-adjacent forms-format-list))
572 (forms--debug "forms-forms-list after 2nd pass:\n"
573 'forms-format-list
574 'forms--number-of-markers)
576 (setq forms--markers (make-vector forms--number-of-markers nil)))
579 ;;;\f
580 ;;; Build the format routine from forms-format-list.
582 ;;; The format routine (forms--format) will look like
583 ;;;
584 ;;; (lambda (arg)
585 ;;; (setq forms--dynamic-text nil)
586 ;;; ;; "text: "
587 ;;; (insert "text: ")
588 ;;; ;; 6
589 ;;; (aset forms--markers 0 (point-marker))
590 ;;; (insert (elt arg 5))
591 ;;; ;; "\nmore text: "
592 ;;; (insert "\nmore text: ")
593 ;;; ;; (tocol 40)
594 ;;; (let ((the-dyntext (tocol 40)))
595 ;;; (insert the-dyntext)
596 ;;; (setq forms--dynamic-text (append forms--dynamic-text
597 ;;; (list the-dyntext))))
598 ;;; ;; 9
599 ;;; (aset forms--markers 1 (point-marker))
600 ;;; (insert (elt arg 8))
602 ;;; ... )
603 ;;;
605 (defun forms--make-format ()
606 "Generate format function for forms"
607 (setq forms--format (forms--format-maker forms-format-list))
608 (forms--debug 'forms--format))
610 (defun forms--format-maker (the-format-list)
611 "Returns the parser function for forms"
612 (let ((the-marker 0))
613 (` (lambda (arg)
614 (setq forms--dynamic-text nil)
615 (,@ (apply 'append
616 (mapcar 'forms--make-format-elt the-format-list)))))))
618 (defun forms--make-format-elt (el)
619 (cond ((stringp el)
620 (` ((insert (, el)))))
621 ((numberp el)
622 (prog1
623 (` ((aset forms--markers (, the-marker) (point-marker))
624 (insert (elt arg (, (1- el))))))
625 (setq the-marker (1+ the-marker))))
626 ((listp el)
627 (prog1
628 (` ((let ((the-dyntext (, el)))
629 (insert the-dyntext)
630 (setq forms--dynamic-text (append forms--dynamic-text
631 (list the-dyntext)))))
636 (defun forms--concat-adjacent (the-list)
637 "Concatenate adjacent strings in the-list and return the resulting list"
638 (if (consp the-list)
639 (let ((the-rest (forms--concat-adjacent (cdr the-list))))
640 (if (and (stringp (car the-list)) (stringp (car the-rest)))
641 (cons (concat (car the-list) (car the-rest))
642 (cdr the-rest))
643 (cons (car the-list) the-rest)))
644 the-list))
645 ;;;\f
646 ;;; forms--make-parser.
648 ;;; Generate parse routine from forms-format-list.
650 ;;; The parse routine (forms--parser) will look like (give or take
651 ;;; a few " " .
652 ;;;
653 ;;; (lambda nil
654 ;;; (let (here)
655 ;;; (goto-char (point-min))
656 ;;;
657 ;;; ;; "text: "
658 ;;; (if (not (looking-at "text: "))
659 ;;; (error "Parse error: cannot find \"text: \""))
660 ;;; (forward-char 6) ; past "text: "
661 ;;;
662 ;;; ;; 6
663 ;;; ;; "\nmore text: "
664 ;;; (setq here (point))
665 ;;; (if (not (search-forward "\nmore text: " nil t nil))
666 ;;; (error "Parse error: cannot find \"\\nmore text: \""))
667 ;;; (aset the-recordv 5 (buffer-substring here (- (point) 12)))
669 ;;; ;; (tocol 40)
670 ;;; (let ((the-dyntext (car-safe forms--dynamic-text)))
671 ;;; (if (not (looking-at (regexp-quote the-dyntext)))
672 ;;; (error "Parse error: not looking at \"%s\"" the-dyntext))
673 ;;; (forward-char (length the-dyntext))
674 ;;; (setq forms--dynamic-text (cdr-safe forms--dynamic-text)))
675 ;;; ...
676 ;;; ;; final flush (due to terminator sentinel, see below)
677 ;;; (aset the-recordv 7 (buffer-substring (point) (point-max)))
678 ;;;
680 (defun forms--make-parser ()
681 "Generate parser function for forms"
682 (setq forms--parser (forms--parser-maker forms-format-list))
683 (forms--debug 'forms--parser))
685 (defun forms--parser-maker (the-format-list)
686 "Returns the parser function for forms"
687 (let ((the-field nil)
688 (seen-text nil)
689 the--format-list)
690 ;; add a terminator sentinel
691 (setq the--format-list (append the-format-list (list nil)))
692 (` (lambda nil
693 (let (here)
694 (goto-char (point-min))
695 (,@ (apply 'append
696 (mapcar 'forms--make-parser-elt the--format-list))))))))
698 (defun forms--make-parser-elt (el)
699 (cond
700 ((stringp el)
701 (prog1
702 (if the-field
703 (` ((setq here (point))
704 (if (not (search-forward (, el) nil t nil))
705 (error "Parse error: cannot find \"%s\"" (, el)))
706 (aset the-recordv (, (1- the-field))
707 (buffer-substring here
708 (- (point) (, (length el)))))))
709 (` ((if (not (looking-at (, (regexp-quote el))))
710 (error "Parse error: not looking at \"%s\"" (, el)))
711 (forward-char (, (length el))))))
712 (setq seen-text t)
713 (setq the-field nil)))
714 ((numberp el)
715 (if the-field
716 (error "Cannot parse adjacent fields %d and %d"
717 the-field el)
718 (setq the-field el)
719 nil))
720 ((null el)
721 (if the-field
722 (` ((aset the-recordv (, (1- the-field))
723 (buffer-substring (point) (point-max)))))))
724 ((listp el)
725 (prog1
726 (if the-field
727 (` ((let ((here (point))
728 (the-dyntext (car-safe forms--dynamic-text)))
729 (if (not (search-forward the-dyntext nil t nil))
730 (error "Parse error: cannot find \"%s\"" the-dyntext))
731 (aset the-recordv (, (1- the-field))
732 (buffer-substring here
733 (- (point) (length the-dyntext))))
734 (setq forms--dynamic-text (cdr-safe forms--dynamic-text)))))
735 (` ((let ((the-dyntext (car-safe forms--dynamic-text)))
736 (if (not (looking-at (regexp-quote the-dyntext)))
737 (error "Parse error: not looking at \"%s\"" the-dyntext))
738 (forward-char (length the-dyntext))
739 (setq forms--dynamic-text (cdr-safe forms--dynamic-text))))))
740 (setq seen-text t)
741 (setq the-field nil)))
743 ;;;\f
745 (defun forms--set-minor-mode ()
746 (setq minor-mode-alist
747 (if forms-read-only
748 " View"
749 nil)))
751 (defun forms--set-keymaps ()
752 "Set the keymaps used in this mode."
754 (if forms-read-only
755 (use-local-map forms-mode-map)
756 (use-local-map (make-sparse-keymap))
757 (define-key (current-local-map) "\C-c" forms-mode-map)
758 (define-key (current-local-map) "\t" 'forms-next-field)))
760 (defun forms--mode-commands (map)
761 "Fill map with all commands."
762 (define-key map "\t" 'forms-next-field)
763 (define-key map " " 'forms-next-record)
764 (define-key map "d" 'forms-delete-record)
765 (define-key map "e" 'forms-edit-mode)
766 (define-key map "i" 'forms-insert-record)
767 (define-key map "j" 'forms-jump-record)
768 (define-key map "n" 'forms-next-record)
769 (define-key map "p" 'forms-prev-record)
770 (define-key map "q" 'forms-exit)
771 (define-key map "s" 'forms-search)
772 (define-key map "v" 'forms-view-mode)
773 (define-key map "x" 'forms-exit-no-save)
774 (define-key map "<" 'forms-first-record)
775 (define-key map ">" 'forms-last-record)
776 (define-key map "?" 'describe-mode)
777 (define-key map "\177" 'forms-prev-record)
778 ; (define-key map "\C-c" map)
779 (define-key map "\e" 'ESC-prefix)
780 (define-key map "\C-x" ctl-x-map)
781 (define-key map "\C-u" 'universal-argument)
782 (define-key map "\C-h" help-map)
784 ;;;\f
785 ;;; Changed functions
787 ;;; Emacs (as of 18.55) lacks the functionality of buffer-local
788 ;;; funtions. Therefore we save the original meaning of some handy
789 ;;; functions, and replace them with a wrapper.
791 (defun forms--change-commands ()
792 "Localize some commands."
794 ;; scroll-down -> forms-prev-record
796 (if (fboundp 'forms--scroll-down)
798 (fset 'forms--scroll-down (symbol-function 'scroll-down))
799 (fset 'scroll-down
800 '(lambda (&optional arg)
801 (interactive "P")
802 (if (and forms--mode-setup
803 forms-forms-scroll)
804 (forms-prev-record arg)
805 (forms--scroll-down arg)))))
807 ;; scroll-up -> forms-next-record
809 (if (fboundp 'forms--scroll-up)
811 (fset 'forms--scroll-up (symbol-function 'scroll-up))
812 (fset 'scroll-up
813 '(lambda (&optional arg)
814 (interactive "P")
815 (if (and forms--mode-setup
816 forms-forms-scroll)
817 (forms-next-record arg)
818 (forms--scroll-up arg)))))
820 ;; beginning-of-buffer -> forms-first-record
822 (if (fboundp 'forms--beginning-of-buffer)
824 (fset 'forms--beginning-of-buffer (symbol-function 'beginning-of-buffer))
825 (fset 'beginning-of-buffer
826 '(lambda ()
827 (interactive)
828 (if (and forms--mode-setup
829 forms-forms-jump)
830 (forms-first-record)
831 (forms--beginning-of-buffer)))))
833 ;; end-of-buffer -> forms-end-record
835 (if (fboundp 'forms--end-of-buffer)
837 (fset 'forms--end-of-buffer (symbol-function 'end-of-buffer))
838 (fset 'end-of-buffer
839 '(lambda ()
840 (interactive)
841 (if (and forms--mode-setup
842 forms-forms-jump)
843 (forms-last-record)
844 (forms--end-of-buffer)))))
846 ;; save-buffer -> forms--save-buffer
848 (if (fboundp 'forms--save-buffer)
850 (fset 'forms--save-buffer (symbol-function 'save-buffer))
851 (fset 'save-buffer
852 '(lambda (&optional arg)
853 (interactive "p")
854 (if forms--mode-setup
855 (progn
856 (forms--checkmod)
857 (save-excursion
858 (set-buffer forms--file-buffer)
859 (forms--save-buffer arg)))
860 (forms--save-buffer arg)))))
864 (defun forms--help ()
865 "Initial help."
866 ;; We should use
867 ;;(message (substitute-command-keys (concat
868 ;;"\\[forms-next-record]:next"
869 ;;" \\[forms-prev-record]:prev"
870 ;;" \\[forms-first-record]:first"
871 ;;" \\[forms-last-record]:last"
872 ;;" \\[describe-mode]:help"
873 ;;" \\[forms-exit]:exit")))
874 ;; but it's too slow ....
875 (if forms-read-only
876 (message "SPC:next DEL:prev <:first >:last ?:help q:exit")
877 (message "C-c n:next C-c p:prev C-c <:first C-c >:last C-c ?:help C-c q:exit")))
879 (defun forms--trans (subj arg rep)
880 "Translate in SUBJ all chars ARG into char REP. ARG and REP should
881 be single-char strings."
882 (let ((i 0)
883 (x (length subj))
884 (re (regexp-quote arg))
885 (k (string-to-char rep)))
886 (while (setq i (string-match re subj i))
887 (aset subj i k)
888 (setq i (1+ i)))))
890 (defun forms--exit (query &optional save)
891 (let ((buf (buffer-name forms--file-buffer)))
892 (forms--checkmod)
893 (if (and save
894 (buffer-modified-p forms--file-buffer))
895 (save-excursion
896 (set-buffer forms--file-buffer)
897 (save-buffer)))
898 (save-excursion
899 (set-buffer forms--file-buffer)
900 (delete-auto-save-file-if-necessary)
901 (kill-buffer (current-buffer)))
902 (if (get-buffer buf) ; not killed???
903 (if save
904 (progn
905 (beep)
906 (message "Problem saving buffers?")))
907 (delete-auto-save-file-if-necessary)
908 (kill-buffer (current-buffer)))))
910 (defun forms--get-record ()
911 "Fetch the current record from the file buffer."
913 ;; This function is executed in the context of the forms--file-buffer.
915 (or (bolp)
916 (beginning-of-line nil))
917 (let ((here (point)))
918 (prog2
919 (end-of-line)
920 (buffer-substring here (point))
921 (goto-char here))))
923 (defun forms--show-record (the-record)
924 "Format THE-RECORD according to forms-format-list,
925 and display it in the current buffer."
927 ;; split the-record
928 (let (the-result
929 (start-pos 0)
930 found-pos
931 (field-sep-length (length forms-field-sep)))
932 (if forms-multi-line
933 (forms--trans the-record forms-multi-line "\n"))
934 ;; add an extra separator (makes splitting easy)
935 (setq the-record (concat the-record forms-field-sep))
936 (while (setq found-pos (string-match forms-field-sep the-record start-pos))
937 (let ((ent (substring the-record start-pos found-pos)))
938 (setq the-result
939 (append the-result (list ent)))
940 (setq start-pos (+ field-sep-length found-pos))))
941 (setq forms--the-record-list the-result))
943 (setq buffer-read-only nil)
944 (erase-buffer)
946 ;; verify the number of fields, extend forms--the-record-list if needed
947 (if (= (length forms--the-record-list) forms-number-of-fields)
949 (beep)
950 (message "Record has %d fields instead of %d."
951 (length forms--the-record-list) forms-number-of-fields)
952 (if (< (length forms--the-record-list) forms-number-of-fields)
953 (setq forms--the-record-list
954 (append forms--the-record-list
955 (make-list
956 (- forms-number-of-fields
957 (length forms--the-record-list))
958 "")))))
960 ;; call the formatter function
961 (setq forms-fields (append (list nil) forms--the-record-list nil))
962 (funcall forms--format forms--the-record-list)
964 ;; prepare
965 (goto-char (point-min))
966 (set-buffer-modified-p nil)
967 (setq buffer-read-only forms-read-only)
968 (setq mode-line-process
969 (concat " " forms--current-record "/" forms--total-records)))
971 (defun forms--parse-form ()
972 "Parse contents of form into list of strings."
973 ;; The contents of the form are parsed, and a new list of strings
974 ;; is constructed.
975 ;; A vector with the strings from the original record is
976 ;; constructed, which is updated with the new contents. Therefore
977 ;; fields which were not in the form are not modified.
978 ;; Finally, the vector is transformed into a list for further processing.
980 (let (the-recordv)
982 ;; build the vector
983 (setq the-recordv (vconcat forms--the-record-list))
985 ;; parse the form and update the vector
986 (let ((forms--dynamic-text forms--dynamic-text))
987 (funcall forms--parser))
989 (if forms--modified-record-filter
990 ;; As a service to the user, we add a zeroth element so she
991 ;; can use the same indices as in the forms definition.
992 (let ((the-fields (vconcat [nil] the-recordv)))
993 (setq the-fields (funcall forms--modified-record-filter the-fields))
994 (cdr (append the-fields nil)))
996 ;; transform to a list and return
997 (append the-recordv nil))))
999 (defun forms--update ()
1000 "Update current record with contents of form. As a side effect: sets
1001 forms--the-record-list ."
1002 (if forms-read-only
1003 (progn
1004 (message "Read-only buffer!")
1005 (beep))
1007 (let (the-record)
1008 ;; build new record
1009 (setq forms--the-record-list (forms--parse-form))
1010 (setq the-record
1011 (mapconcat 'identity forms--the-record-list forms-field-sep))
1013 ;; handle multi-line fields, if allowed
1014 (if forms-multi-line
1015 (forms--trans the-record "\n" forms-multi-line))
1017 ;; a final sanity check before updating
1018 (if (string-match "\n" the-record)
1019 (progn
1020 (message "Multi-line fields in this record - update refused!")
1021 (beep))
1023 (save-excursion
1024 (set-buffer forms--file-buffer)
1025 ;; Insert something before kill-line is called. See kill-line
1026 ;; doc. Bugfix provided by Ignatios Souvatzis.
1027 (insert "*")
1028 (beginning-of-line)
1029 (kill-line nil)
1030 (insert the-record)
1031 (beginning-of-line))))))
1033 (defun forms--checkmod ()
1034 "Check if this form has been modified, and call forms--update if so."
1035 (if (buffer-modified-p nil)
1036 (let ((here (point)))
1037 (forms--update)
1038 (set-buffer-modified-p nil)
1039 (goto-char here))))
1041 ;;;\f
1042 ;;; Start and exit
1043 (defun forms-find-file (fn)
1044 "Visit file FN in forms mode"
1045 (interactive "fForms file: ")
1046 (find-file-read-only fn)
1047 (or forms--mode-setup (forms-mode t)))
1049 (defun forms-find-file-other-window (fn)
1050 "Visit file FN in form mode in other window"
1051 (interactive "fFbrowse file in other window: ")
1052 (find-file-other-window fn)
1053 (eval-current-buffer)
1054 (or forms--mode-setup (forms-mode t)))
1056 (defun forms-exit (query)
1057 "Normal exit. Modified buffers are saved."
1058 (interactive "P")
1059 (forms--exit query t))
1061 (defun forms-exit-no-save (query)
1062 "Exit without saving buffers."
1063 (interactive "P")
1064 (forms--exit query nil))
1066 ;;;\f
1067 ;;; Navigating commands
1069 (defun forms-next-record (arg)
1070 "Advance to the ARGth following record."
1071 (interactive "P")
1072 (forms-jump-record (+ forms--current-record (prefix-numeric-value arg)) t))
1074 (defun forms-prev-record (arg)
1075 "Advance to the ARGth previous record."
1076 (interactive "P")
1077 (forms-jump-record (- forms--current-record (prefix-numeric-value arg)) t))
1079 (defun forms-jump-record (arg &optional relative)
1080 "Jump to a random record."
1081 (interactive "NRecord number: ")
1083 ;; verify that the record number is within range
1084 (if (or (> arg forms--total-records)
1085 (<= arg 0))
1086 (progn
1087 (beep)
1088 ;; don't give the message if just paging
1089 (if (not relative)
1090 (message "Record number %d out of range 1..%d"
1091 arg forms--total-records))
1094 ;; flush
1095 (forms--checkmod)
1097 ;; calculate displacement
1098 (let ((disp (- arg forms--current-record))
1099 (cur forms--current-record))
1101 ;; forms--show-record needs it now
1102 (setq forms--current-record arg)
1104 ;; get the record and show it
1105 (forms--show-record
1106 (save-excursion
1107 (set-buffer forms--file-buffer)
1108 (beginning-of-line)
1110 ;; move, and adjust the amount if needed (shouldn't happen)
1111 (if relative
1112 (if (zerop disp)
1114 (setq cur (+ cur disp (- (forward-line disp)))))
1115 (setq cur (+ cur disp (- (goto-line arg)))))
1117 (forms--get-record)))
1119 ;; this shouldn't happen
1120 (if (/= forms--current-record cur)
1121 (progn
1122 (setq forms--current-record cur)
1123 (beep)
1124 (message "Stuck at record %d." cur))))))
1126 (defun forms-first-record ()
1127 "Jump to first record."
1128 (interactive)
1129 (forms-jump-record 1))
1131 (defun forms-last-record ()
1132 "Jump to last record. As a side effect: re-calculates the number
1133 of records in the data file."
1134 (interactive)
1135 (let
1136 ((numrec
1137 (save-excursion
1138 (set-buffer forms--file-buffer)
1139 (count-lines (point-min) (point-max)))))
1140 (if (= numrec forms--total-records)
1142 (beep)
1143 (setq forms--total-records numrec)
1144 (message "Number of records reset to %d." forms--total-records)))
1145 (forms-jump-record forms--total-records))
1147 ;;;\f
1148 ;;; Other commands
1149 (defun forms-view-mode ()
1150 "Visit buffer read-only."
1151 (interactive)
1152 (if forms-read-only
1154 (forms--checkmod) ; sync
1155 (setq forms-read-only t)
1156 (forms-mode)))
1158 (defun forms-edit-mode ()
1159 "Make form suitable for editing, if possible."
1160 (interactive)
1161 (let ((ro forms-read-only))
1162 (if (save-excursion
1163 (set-buffer forms--file-buffer)
1164 buffer-read-only)
1165 (progn
1166 (setq forms-read-only t)
1167 (message "No write access to \"%s\"" forms-file)
1168 (beep))
1169 (setq forms-read-only nil))
1170 (if (equal ro forms-read-only)
1172 (forms-mode))))
1174 ;; Sample:
1175 ;; (defun my-new-record-filter (the-fields)
1176 ;; ;; numbers are relative to 1
1177 ;; (aset the-fields 4 (current-time-string))
1178 ;; (aset the-fields 6 (user-login-name))
1179 ;; the-list)
1180 ;; (setq forms-new-record-filter 'my-new-record-filter)
1182 (defun forms-insert-record (arg)
1183 "Create a new record before the current one. With ARG: store the
1184 record after the current one.
1185 If a function forms-new-record-filter is defined, or forms-new-record-filter
1186 contains the name of a function, it is called to
1187 fill (some of) the fields with default values."
1188 ; The above doc is not true, but for documentary purposes only
1190 (interactive "P")
1192 (let ((ln (if arg (1+ forms--current-record) forms--current-record))
1193 the-list the-record)
1195 (forms--checkmod)
1196 (if forms--new-record-filter
1197 ;; As a service to the user, we add a zeroth element so she
1198 ;; can use the same indices as in the forms definition.
1199 (let ((the-fields (make-vector (1+ forms-number-of-fields) "")))
1200 (setq the-fields (funcall forms--new-record-filter the-fields))
1201 (setq the-list (cdr (append the-fields nil))))
1202 (setq the-list (make-list forms-number-of-fields "")))
1204 (setq the-record
1205 (mapconcat
1206 'identity
1207 the-list
1208 forms-field-sep))
1210 (save-excursion
1211 (set-buffer forms--file-buffer)
1212 (goto-line ln)
1213 (open-line 1)
1214 (insert the-record)
1215 (beginning-of-line))
1217 (setq forms--current-record ln))
1219 (setq forms--total-records (1+ forms--total-records))
1220 (forms-jump-record forms--current-record))
1222 (defun forms-delete-record (arg)
1223 "Deletes a record. With ARG: don't ask."
1224 (interactive "P")
1225 (forms--checkmod)
1226 (if (or arg
1227 (y-or-n-p "Really delete this record? "))
1228 (let ((ln forms--current-record))
1229 (save-excursion
1230 (set-buffer forms--file-buffer)
1231 (goto-line ln)
1232 (kill-line 1))
1233 (setq forms--total-records (1- forms--total-records))
1234 (if (> forms--current-record forms--total-records)
1235 (setq forms--current-record forms--total-records))
1236 (forms-jump-record forms--current-record)))
1237 (message ""))
1239 (defun forms-search (regexp)
1240 "Search REGEXP in file buffer."
1241 (interactive
1242 (list (read-string (concat "Search for"
1243 (if forms--search-regexp
1244 (concat " ("
1245 forms--search-regexp
1246 ")"))
1247 ": "))))
1248 (if (equal "" regexp)
1249 (setq regexp forms--search-regexp))
1250 (forms--checkmod)
1252 (let (the-line the-record here
1253 (fld-sep forms-field-sep))
1254 (if (save-excursion
1255 (set-buffer forms--file-buffer)
1256 (setq here (point))
1257 (end-of-line)
1258 (if (null (re-search-forward regexp nil t))
1259 (progn
1260 (goto-char here)
1261 (message (concat "\"" regexp "\" not found."))
1262 nil)
1263 (setq the-record (forms--get-record))
1264 (setq the-line (1+ (count-lines (point-min) (point))))))
1265 (progn
1266 (setq forms--current-record the-line)
1267 (forms--show-record the-record)
1268 (re-search-forward regexp nil t))))
1269 (setq forms--search-regexp regexp))
1271 (defun forms-revert-buffer (&optional arg noconfirm)
1272 "Reverts current form to un-modified."
1273 (interactive "P")
1274 (if (or noconfirm
1275 (yes-or-no-p "Revert form to unmodified? "))
1276 (progn
1277 (set-buffer-modified-p nil)
1278 (forms-jump-record forms--current-record))))
1280 (defun forms-next-field (arg)
1281 "Jump to ARG-th next field."
1282 (interactive "p")
1284 (let ((i 0)
1285 (here (point))
1286 there
1287 (cnt 0))
1289 (if (zerop arg)
1290 (setq cnt 1)
1291 (setq cnt (+ cnt arg)))
1293 (if (catch 'done
1294 (while (< i forms--number-of-markers)
1295 (if (or (null (setq there (aref forms--markers i)))
1296 (<= there here))
1298 (if (<= (setq cnt (1- cnt)) 0)
1299 (progn
1300 (goto-char there)
1301 (throw 'done t))))
1302 (setq i (1+ i))))
1304 (goto-char (aref forms--markers 0)))))
1307 ;;; Special service
1309 (defun forms-enumerate (the-fields)
1310 "Take a quoted list of symbols, and set their values to the numbers
1311 1, 2 and so on. Returns the higest number.
1313 Usage: (setq forms-number-of-fields
1314 (forms-enumerate
1315 '(field1 field2 field2 ...)))"
1317 (let ((the-index 0))
1318 (while the-fields
1319 (setq the-index (1+ the-index))
1320 (let ((el (car-safe the-fields)))
1321 (setq the-fields (cdr-safe the-fields))
1322 (set el the-index)))
1323 the-index))
1325 ;;;\f
1326 ;;; Debugging
1328 (defvar forms--debug nil
1329 "*Enables forms-mode debugging if not nil.")
1331 (defun forms--debug (&rest args)
1332 "Internal - debugging routine"
1333 (if forms--debug
1334 (let ((ret nil))
1335 (while args
1336 (let ((el (car-safe args)))
1337 (setq args (cdr-safe args))
1338 (if (stringp el)
1339 (setq ret (concat ret el))
1340 (setq ret (concat ret (prin1-to-string el) " = "))
1341 (if (boundp el)
1342 (let ((vel (eval el)))
1343 (setq ret (concat ret (prin1-to-string vel) "\n")))
1344 (setq ret (concat ret "<unbound>" "\n")))
1345 (if (fboundp el)
1346 (setq ret (concat ret (prin1-to-string (symbol-function el))
1347 "\n"))))))
1348 (save-excursion
1349 (set-buffer (get-buffer-create "*forms-mode debug*"))
1350 (goto-char (point-max))
1351 (insert ret)))))
1353 ;;; Local Variables:
1354 ;;; eval: (headers)
1355 ;;; eval: (setq comment-start ";;; ")
1356 ;;; End: