Source Code 1992 March/Source_Code_CD-ROM_Walnut_Creek_March_1992.iso/usenet/altsrcs/3/3375

Internet Message Format | 1991-05-21 | 19.0 KB

From: [e-mail] (Johan Vromans)
Newsgroups: gnu.emacs.sources,alt.sources
Subject: GNU Emacs forms-mode version 1.2.2, part 3 of 3
Message-ID: <[e-mail]>
Date: 20 May 91 09:32:08 GMT

Submitted-by: [e-mail]
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                       [e-mail] via internet backbones
Multihouse Automatisering bv               uucp: ..!{uunet,hp4nl}!mh.nl!jv
Doesburgweg 7, 2803 PL Gouda, The Netherlands  phone/fax: [phone]/62500
------------------------ "Arms are made for hugging" -------------------------