jv@mh.nl (Johan Vromans) (05/20/91)
Submitted-by: jv@mh.nl
Archive-name: forms/part03
---- Cut Here and feed the following to sh ----
#!/bin/sh
# this is forms.shr.03 (part 3 of forms)
# do not concatenate these parts, unpack them in order with /bin/sh
# file forms.el continued
#
if test ! -r _shar_seq_.tmp; then
echo 'Please unpack part 1 first!'
exit 1
fi
(read Scheck
if test "$Scheck" != 3; then
echo Please unpack part "$Scheck" next!
exit 1
else
exit 0
fi
) < _shar_seq_.tmp || exit 1
if test ! -f _shar_wnt_.tmp; then
echo 'x - still skipping forms.el'
else
echo 'x - continuing file forms.el'
sed 's/^X//' << 'SHAR_EOF' >> 'forms.el' &&
;;; (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)))
;;; ...
;;; ...
;;; ;; final flush (due to terminator sentinel, see below)
;;; (aset the-recordv 7 (buffer-substring (point) (point-max)))
;;;
X
(defun forms--make-parser ()
X "Generate parser function for forms"
X (setq forms--parser (forms--parser-maker forms-format-list)))
X
(defun forms--parser-maker (the-format-list)
X "Returns the parser function for forms"
X (let ((the-field nil)
X (seen-text nil)
X the--format-list)
X ;; concat adjacent strings and add a terminator sentinel
X (setq the--format-list
X (append (forms--concat-adjacent the-format-list) (list nil)))
X (` (lambda nil
X (let (here)
X (goto-char (point-min))
X (,@ (apply 'append
X (mapcar 'forms--make-parser-elt the--format-list))))))))
X
(defun forms--make-parser-elt (el)
X (cond ((stringp el)
X (prog1
X (if the-field
X (` ((setq here (point))
X (if (not (search-forward (, el) nil t nil))
X (error "Parse error: cannot find %s" (, el)))
X (aset the-recordv (, (1- the-field))
X (buffer-substring here
X (- (point) (, (length el)))))))
X (` ((if (not (looking-at (, (regexp-quote el))))
X (error "Parse error: not looking at %s" (, el)))
X (forward-char (, (length el))))))
X (setq seen-text t)
X (setq the-field nil)))
X ((numberp el)
X (if the-field
X (error "Cannot parse adjacent fields %d and %d"
X the-field el)
X (setq the-field el)
X nil))
X ((null el)
X (if the-field
X (` ((aset the-recordv (, (1- the-field))
X (buffer-substring (point) (point-max)))))))))
;;;
X
(defun forms--set-minor-mode ()
X (setq minor-mode-alist
X (if forms-read-only
X " View"
X nil)))
X
(defun forms--set-keymaps ()
X "Set the keymaps used in this mode."
X
X (if forms-read-only
X (use-local-map forms-mode-map)
X (use-local-map (make-sparse-keymap))
X (define-key (current-local-map) "\C-c" forms-mode-map)
X (define-key (current-local-map) "\t" 'forms-next-field)))
X
(defun forms--mode-commands (map)
X "Fill map with all commands."
X (define-key map "\t" 'forms-next-field)
X (define-key map " " 'forms-next-record)
X (define-key map "d" 'forms-delete-record)
X (define-key map "e" 'forms-edit-mode)
X (define-key map "i" 'forms-insert-record)
X (define-key map "j" 'forms-jump-record)
X (define-key map "n" 'forms-next-record)
X (define-key map "p" 'forms-prev-record)
X (define-key map "q" 'forms-exit)
X (define-key map "s" 'forms-search)
X (define-key map "v" 'forms-view-mode)
X (define-key map "x" 'forms-exit-no-save)
X (define-key map "<" 'forms-first-record)
X (define-key map ">" 'forms-last-record)
X (define-key map "?" 'describe-mode)
X (define-key map "\177" 'forms-prev-record)
X ; (define-key map "\C-c" map)
X (define-key map "\e" 'ESC-prefix)
X (define-key map "\C-x" ctl-x-map)
X (define-key map "\C-u" 'universal-argument)
X (define-key map "\C-h" help-map)
X )
;;;
;;; 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.
X
(defun forms--change-commands ()
X "Localize some commands."
X ;;
X ;; scroll-down -> forms-prev-record
X ;;
X (if (fboundp 'forms--scroll-down)
X nil
X (fset 'forms--scroll-down (symbol-function 'scroll-down))
X (fset 'scroll-down
X '(lambda (arg)
X (interactive "P")
X (if (and forms--mode-setup
X forms-forms-scroll)
X (forms-prev-record arg)
X (forms--scroll-down arg)))))
X ;;
X ;; scroll-up -> forms-next-record
X ;;
X (if (fboundp 'forms--scroll-up)
X nil
X (fset 'forms--scroll-up (symbol-function 'scroll-up))
X (fset 'scroll-up
X '(lambda (arg)
X (interactive "P")
X (if (and forms--mode-setup
X forms-forms-scroll)
X (forms-next-record arg)
X (forms--scroll-up arg)))))
X ;;
X ;; beginning-of-buffer -> forms-first-record
X ;;
X (if (fboundp 'forms--beginning-of-buffer)
X nil
X (fset 'forms--beginning-of-buffer (symbol-function 'beginning-of-buffer))
X (fset 'beginning-of-buffer
X '(lambda ()
X (interactive)
X (if (and forms--mode-setup
X forms-forms-jump)
X (forms-first-record)
X (forms--beginning-of-buffer)))))
X ;;
X ;; end-of-buffer -> forms-end-record
X ;;
X (if (fboundp 'forms--end-of-buffer)
X nil
X (fset 'forms--end-of-buffer (symbol-function 'end-of-buffer))
X (fset 'end-of-buffer
X '(lambda ()
X (interactive)
X (if (and forms--mode-setup
X forms-forms-jump)
X (forms-last-record)
X (forms--end-of-buffer)))))
X ;;
X ;; save-buffer -> forms--save-buffer
X ;;
X (if (fboundp 'forms--save-buffer)
X nil
X (fset 'forms--save-buffer (symbol-function 'save-buffer))
X (fset 'save-buffer
X '(lambda (&optional arg)
X (interactive "p")
X (if forms--mode-setup
X (progn
X (forms--checkmod)
X (save-excursion
X (set-buffer forms--file-buffer)
X (forms--save-buffer arg)))
X (forms--save-buffer arg)))))
X ;;
X )
X
(defun forms--help ()
X "Initial help."
X ;; We should use
X ;;(message (substitute-command-keys (concat
X ;;"\\[forms-next-record]:next"
X ;;" \\[forms-prev-record]:prev"
X ;;" \\[forms-first-record]:first"
X ;;" \\[forms-last-record]:last"
X ;;" \\[describe-mode]:help"
X ;;" \\[forms-exit]:exit")))
X ;; but it's too slow ....
X (if forms-read-only
X (message "SPC:next DEL:prev <:first >:last ?:help q:exit")
X (message "C-c n:next C-c p:prev C-c <:first C-c >:last C-c ?:help C-c q:exit")))
X
(defun forms--trans (subj arg rep)
X "Translate in SUBJ all chars ARG into char REP. ARG and REP should
X be single-char strings."
X (let ((i 0)
X (x (length subj))
X (re (regexp-quote arg))
X (k (string-to-char rep)))
X (while (setq i (string-match re subj i))
X (aset subj i k)
X (setq i (1+ i)))))
X
(defun forms--exit (query &optional save)
X (let ((buf (buffer-name forms--file-buffer)))
X (forms--checkmod)
X (if (and save
X (buffer-modified-p forms--file-buffer))
X (save-excursion
X (set-buffer forms--file-buffer)
X (save-buffer)))
X (save-excursion
X (set-buffer forms--file-buffer)
X (delete-auto-save-file-if-necessary)
X (kill-buffer (current-buffer)))
X (if (get-buffer buf) ; not killed???
X (if save
X (progn
X (beep)
X (message "Problem saving buffers?")))
X (delete-auto-save-file-if-necessary)
X (kill-buffer (current-buffer)))))
X
(defun forms--get-record ()
X "Fetch the current record from the file buffer."
X ;;
X ;; This function is executed in the context of the forms--file-buffer.
X ;;
X (or (bolp)
X (beginning-of-line nil))
X (let ((here (point)))
X (prog2
X (end-of-line)
X (buffer-substring here (point))
X (goto-char here))))
X
(defun forms--show-record (the-record)
X "Format THE-RECORD according to forms-format-list,
X and display it in the current buffer."
X
X ;; split the-record
X (let (the-result
X (start-pos 0)
X found-pos
X (field-sep-length (length forms-field-sep)))
X (if forms-multi-line
X (forms--trans the-record forms-multi-line "\n"))
X ;; add an extra separator (makes splitting easy)
X (setq the-record (concat the-record forms-field-sep))
X (while (setq found-pos (string-match forms-field-sep the-record start-pos))
X (let ((ent (substring the-record start-pos found-pos)))
X (setq the-result
X (append the-result (list ent)))
X (setq start-pos (+ field-sep-length found-pos))))
X (setq forms--the-record-list the-result))
X
X (setq buffer-read-only nil)
X (erase-buffer)
X
X ;; verify the number of fields, extend forms--the-record-list if needed
X (if (= (length forms--the-record-list) forms-number-of-fields)
X nil
X (beep)
X (message "Record has %d fields instead of %d."
X (length forms--the-record-list) forms-number-of-fields)
X (if (< (length forms--the-record-list) forms-number-of-fields)
X (setq forms--the-record-list
X (append forms--the-record-list
X (make-list
X (- forms-number-of-fields
X (length forms--the-record-list))
X "")))))
X
X ;; call the formatter function
X (funcall forms--format forms--the-record-list)
X
X ;; prepare
X (goto-char (point-min))
X (set-buffer-modified-p nil)
X (setq buffer-read-only forms-read-only)
X (setq mode-line-process
X (concat " " forms--current-record "/" forms--total-records)))
X
(defun forms--parse-form ()
X "Parse contents of form into list of strings."
X ;; The contents of the form are parsed, and a new list of strings
X ;; is constructed.
X ;; A vector with the strings from the original record is
X ;; constructed, which is updated with the new contents. Therefore
X ;; fields which were not in the form are not modified.
X ;; Finally, the vector is transformed into a list for further processing.
X
X (let (the-recordv)
X
X ;; build the vector
X (setq the-recordv (vconcat forms--the-record-list))
X
X ;; parse the form and update the vector
X (funcall forms--parser)
X
X ;; transform to a list and return
X (append the-recordv nil)))
X
(defun forms--update ()
X "Update current record with contents of form. As a side effect: sets
forms--the-record-list ."
X (if forms-read-only
X (progn
X (message "Read-only buffer!")
X (beep))
X
X (let (the-record)
X ;; build new record
X (setq forms--the-record-list (forms--parse-form))
X (setq the-record
X (mapconcat 'identity forms--the-record-list forms-field-sep))
X
X ;; handle multi-line fields, if allowed
X (if forms-multi-line
X (forms--trans the-record "\n" forms-multi-line))
X
X ;; a final sanity check before updating
X (if (string-match "\n" the-record)
X (progn
X (message "Multi-line fields in this record - update refused!")
X (beep))
X
X (save-excursion
X (set-buffer forms--file-buffer)
X ;; Insert something before kill-line is called. See kill-line
X ;; doc. Bugfix provided by Ignatios Souvatzis.
X (insert "*")
X (beginning-of-line)
X (kill-line nil)
X (insert the-record)
X (beginning-of-line))))))
X
(defun forms--checkmod ()
X "Check if this form has been modified, and call forms--update if so."
X (if (buffer-modified-p nil)
X (let ((here (point)))
X (forms--update)
X (set-buffer-modified-p nil)
X (goto-char here))))
X
;;;
;;; Start and exit
(defun forms-find-file (fn)
X "Visit file FN in forms mode"
X (interactive "fForms file: ")
X (find-file-read-only fn)
X (or forms--mode-setup (forms-mode t)))
X
(defun forms-find-file-other-window (fn)
X "Visit file FN in form mode in other window"
X (interactive "fFbrowse file in other window: ")
X (find-file-other-window fn)
X (eval-current-buffer)
X (or forms--mode-setup (forms-mode t)))
X
(defun forms-exit (query)
X "Normal exit. Modified buffers are saved."
X (interactive "P")
X (forms--exit query t))
X
(defun forms-exit-no-save (query)
X "Exit without saving buffers."
X (interactive "P")
X (forms--exit query nil))
X
;;;
;;; Navigating commands
X
(defun forms-next-record (arg)
X "Advance to the ARGth following record."
X (interactive "P")
X (forms-jump-record (+ forms--current-record (prefix-numeric-value arg)) t))
X
(defun forms-prev-record (arg)
X "Advance to the ARGth previous record."
X (interactive "P")
X (forms-jump-record (- forms--current-record (prefix-numeric-value arg)) t))
X
(defun forms-jump-record (arg &optional relative)
X "Jump to a random record."
X (interactive "NRecord number: ")
X
X ;; verify that the record number is within range
X (if (or (> arg forms--total-records)
X (<= arg 0))
X (progn
X (beep)
X ;; don't give the message if just paging
X (if (not relative)
X (message "Record number %d out of range 1..%d"
X arg forms--total-records))
X )
X
X ;; flush
X (forms--checkmod)
X
X ;; calculate displacement
X (let ((disp (- arg forms--current-record))
X (cur forms--current-record))
X
X ;; forms--show-record needs it now
X (setq forms--current-record arg)
X
X ;; get the record and show it
X (forms--show-record
X (save-excursion
X (set-buffer forms--file-buffer)
X (beginning-of-line)
X
X ;; move, and adjust the amount if needed (shouldn't happen)
X (if relative
X (if (zerop disp)
X nil
X (setq cur (+ cur disp (- (forward-line disp)))))
X (setq cur (+ cur disp (- (goto-line arg)))))
X
X (forms--get-record)))
X
X ;; this shouldn't happen
X (if (/= forms--current-record cur)
X (progn
X (setq forms--current-record cur)
X (beep)
X (message "Stuck at record %d." cur))))))
X
(defun forms-first-record ()
X "Jump to first record."
X (interactive)
X (forms-jump-record 1))
X
(defun forms-last-record ()
X "Jump to last record. As a side effect: re-calculates the number
X of records in the data file."
X (interactive)
X (let
X ((numrec
X (save-excursion
X (set-buffer forms--file-buffer)
X (count-lines (point-min) (point-max)))))
X (if (= numrec forms--total-records)
X nil
X (beep)
X (setq forms--total-records numrec)
X (message "Number of records reset to %d." forms--total-records)))
X (forms-jump-record forms--total-records))
X
;;;
;;; Other commands
(defun forms-view-mode ()
X "Visit buffer read-only."
X (interactive)
X (if forms-read-only
X nil
X (forms--checkmod) ; sync
X (setq forms-read-only t)
X (forms-mode)))
X
(defun forms-edit-mode ()
X "Make form suitable for editing, if possible."
X (interactive)
X (let ((ro forms-read-only))
X (if (save-excursion
X (set-buffer forms--file-buffer)
X buffer-read-only)
X (progn
X (setq forms-read-only t)
X (message "No write access to \"%s\"" forms-file)
X (beep))
X (setq forms-read-only nil))
X (if (equal ro forms-read-only)
X nil
X (forms-mode))))
X
;; Sample:
;; (defun forms-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)
X
(defun forms-insert-record (arg)
X "Create a new record before the current one. With ARG: store the
X record after the current one.
X If a function forms-new-record-filter is defined, is is called to
X fill (some of) the fields with default values."
X ; The above doc is not true, but for documentary purposes only
X
X (interactive "P")
X
X (let ((ln (if arg (1+ forms--current-record) forms--current-record))
X the-list the-record)
X
X (forms--checkmod)
X (if forms--new-record-filter
X ;; As a service to the user, we add a zeroth element so she
X ;; can use the same indices as in the forms definition.
X (let ((the-fields (make-vector (1+ forms-number-of-fields) "")))
X (setq the-fields (funcall forms--new-record-filter the-fields))
X (setq the-list (cdr (append the-fields nil))))
X (setq the-list (make-list forms-number-of-fields "")))
X
X (setq the-record
X (mapconcat
X 'identity
X the-list
X forms-field-sep))
X
X (save-excursion
X (set-buffer forms--file-buffer)
X (goto-line ln)
X (open-line 1)
X (insert the-record)
X (beginning-of-line))
X
X (setq forms--current-record ln))
X
X (setq forms--total-records (1+ forms--total-records))
X (forms-jump-record forms--current-record))
X
(defun forms-delete-record (arg)
X "Deletes a record. With ARG: don't ask."
X (interactive "P")
X (forms--checkmod)
X (if (or arg
X (y-or-n-p "Really delete this record? "))
X (let ((ln forms--current-record))
X (save-excursion
X (set-buffer forms--file-buffer)
X (goto-line ln)
X (kill-line 1))
X (setq forms--total-records (1- forms--total-records))
X (if (> forms--current-record forms--total-records)
X (setq forms--current-record forms--total-records))
X (forms-jump-record forms--current-record)))
X (message ""))
X
(defun forms-search (regexp)
X "Search REGEXP in file buffer."
X (interactive
X (list (read-string (concat "Search for"
X (if forms--search-regexp
X (concat " ("
X forms--search-regexp
X ")"))
X ": "))))
X (if (equal "" regexp)
X (setq regexp forms--search-regexp))
X (forms--checkmod)
X
X (let (the-line the-record here
X (fld-sep forms-field-sep))
X (if (save-excursion
X (set-buffer forms--file-buffer)
X (setq here (point))
X (end-of-line)
X (if (null (re-search-forward regexp nil t))
X (progn
X (goto-char here)
X (message (concat "\"" regexp "\" not found."))
X nil)
X (setq the-record (forms--get-record))
X (setq the-line (1+ (count-lines (point-min) (point))))))
X (progn
X (setq forms--current-record the-line)
X (forms--show-record the-record)
X (re-search-forward regexp nil t))))
X (setq forms--search-regexp regexp))
X
(defun forms-revert-buffer (&optional arg noconfirm)
X "Reverts current form to un-modified."
X (interactive "P")
X (if (or noconfirm
X (yes-or-no-p "Revert form to unmodified? "))
X (progn
X (set-buffer-modified-p nil)
X (forms-jump-record forms--current-record))))
X
(defun forms-next-field (arg)
X "Jump to ARG-th next field."
X (interactive "p")
X
X (let ((i 0)
X (here (point))
X there
X (cnt 0))
X
X (if (zerop arg)
X (setq cnt 1)
X (setq cnt (+ cnt arg)))
X
X (if (catch 'done
X (while (< i forms--number-of-markers)
X (if (or (null (setq there (aref forms--markers i)))
X (<= there here))
X nil
X (if (<= (setq cnt (1- cnt)) 0)
X (progn
X (goto-char there)
X (throw 'done t))))
X (setq i (1+ i))))
X nil
X (goto-char (aref forms--markers 0)))))
SHAR_EOF
echo 'File forms.el is complete' &&
chmod 0444 forms.el ||
echo 'restore of forms.el failed'
Wc_c="`wc -c < 'forms.el'`"
test 36048 -eq "$Wc_c" ||
echo 'forms.el: original size 36048, current size' "$Wc_c"
rm -f _shar_wnt_.tmp
fi
rm -f _shar_seq_.tmp
echo You have unpacked the last part
exit 0
--
Johan Vromans jv@mh.nl via internet backbones
Multihouse Automatisering bv uucp: ..!{uunet,hp4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands phone/fax: +31 1820 62911/62500
------------------------ "Arms are made for hugging" -------------------------