lisp/forms.el

   1 ;;; forms.el -- Forms mode: edit a file as a form to fill in.
   2 ;;; Copyright (C) 1991, 1993 Free Software Foundation, Inc.
   3
   4 ;; Author: Johan Vromans <jv@mh.nl>
   5 ;; Version: $Revision: 2.3 $
   6
   7 ;; This file is part of GNU Emacs.
   8
   9 ;; GNU Emacs is free software; you can redistribute it and/or modify
  10 ;; it under the terms of the GNU General Public License as published by
  11 ;; the Free Software Foundation; either version 2, or (at your option)
  12 ;; any later version.
  13
  14 ;; GNU Emacs is distributed in the hope that it will be useful,
  15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  17 ;; GNU General Public License for more details.
  18
  19 ;; You should have received a copy of the GNU General Public License
  20 ;; along with GNU Emacs; see the file COPYING.  If not, write to
  21 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
  22
  23 ;;; Commentary:
  24
  25 ;;; Visit a file using a form.
  26 ;;;
  27 ;;; === Naming conventions
  28 ;;;
  29 ;;; The names of all variables and functions start with 'forms-'.
  30 ;;; Names which start with 'forms--' are intended for internal use, and
  31 ;;; should *NOT* be used from the outside.
  32 ;;;
  33 ;;; All variables are buffer-local, to enable multiple forms visits
  34 ;;; simultaneously.
  35 ;;; Variable `forms--mode-setup' is local to *ALL* buffers, for it
  36 ;;; controls if forms-mode has been enabled in a buffer.
  37 ;;;
  38 ;;; === How it works ===
  39 ;;;
  40 ;;; Forms mode means visiting a data file which is supposed to consist
  41 ;;; of records each containing a number of fields.  The records are
  42 ;;; separated by a newline, the fields are separated by a user-defined
  43 ;;; field separater (default: TAB).
  44 ;;; When shown, a record is transferred to an Emacs buffer and
  45 ;;; presented using a user-defined form.  One record is shown at a
  46 ;;; time.
  47 ;;;
  48 ;;; Forms mode is a composite mode.  It involves two files, and two
  49 ;;; buffers.
  50 ;;; The first file, called the control file, defines the name of the
  51 ;;; data file and the forms format.  This file buffer will be used to
  52 ;;; present the forms.
  53 ;;; The second file holds the actual data.  The buffer of this file
  54 ;;; will be buried, for it is never accessed directly.
  55 ;;;
  56 ;;; Forms mode is invoked using M-x forms-find-file control-file .
  57 ;;; Alternativily `forms-find-file-other-window' can be used.
  58 ;;;
  59 ;;; You may also visit the control file, and switch to forms mode by hand
  60 ;;; with M-x forms-mode .
  61 ;;;
  62 ;;; Automatic mode switching is supported if you specify
  63 ;;; "-*- forms -*-" in the first line of the control file.
  64 ;;;
  65 ;;; The control file is visited, evaluated using `eval-current-buffer',
  66 ;;; and should set at least the following variables:
  67 ;;;
  68 ;;;     forms-file                              [string]
  69 ;;;                     The name of the data file.
  70 ;;;
  71 ;;;     forms-number-of-fields                  [integer]
  72 ;;;                     The number of fields in each record.
  73 ;;;
  74 ;;;     forms-format-list                       [list]
  75 ;;;                     Formatting instructions.
  76 ;;;
  77 ;;; `forms-format-list' should be a list, each element containing
  78 ;;;
  79 ;;;   - a string, e.g. "hello".  The string is inserted in the forms
  80 ;;;     "as is".
  81 ;;;
  82 ;;;   - an integer, denoting a field number.
  83 ;;;     The contents of this field are inserted at this point.
  84 ;;;     Fields are numbered starting with number one.
  85 ;;;
  86 ;;;   - a function call, e.g. (insert "text").
  87 ;;;     This function call is dynamically evaluated and should return a
  88 ;;;     string.  It should *NOT* have side-effects on the forms being
  89 ;;;     constructed.  The current fields are available to the function
  90 ;;;     in the variable `forms-fields', they should *NOT* be modified.
  91 ;;;
  92 ;;;   - a lisp symbol, that must evaluate to one of the above.
  93 ;;;
  94 ;;; Optional variables which may be set in the control file:
  95 ;;;
  96 ;;;     forms-field-sep                         [string, default TAB]
  97 ;;;                     The field separator used to separate the
  98 ;;;                     fields in the data file.  It may be a string.
  99 ;;;
 100 ;;;     forms-read-only                         [bool, default nil]
 101 ;;;                     Non-nil means that the data file is visited
 102 ;;;                     read-only (view mode) as opposed to edit mode.
 103 ;;;                     If no write access to the data file is
 104 ;;;                     possible, view mode is enforced.
 105 ;;;
 106 ;;;     forms-multi-line                        [string, default "^K"]
 107 ;;;                     If non-null the records of the data file may
 108 ;;;                     contain fields that can span multiple lines in
 109 ;;;                     the form.
 110 ;;;                     This variable denotes the separator character
 111 ;;;                     to be used for this purpose.  Upon display, all
 112 ;;;                     occurrencies of this character are translated
 113 ;;;                     to newlines.  Upon storage they are translated
 114 ;;;                     back to the separator character.
 115 ;;;
 116 ;;;     forms-forms-scroll                      [bool, default nil]
 117 ;;;                     Non-nil means: rebind locally the commands that
 118 ;;;                     perform `scroll-up' or `scroll-down' to use
 119 ;;;                     `forms-next-field' resp. `forms-prev-field'.
 120 ;;;
 121 ;;;     forms-forms-jump                        [bool, default nil]
 122 ;;;                     Non-nil means: rebind locally the commands that
 123 ;;;                     perform `beginning-of-buffer' or `end-of-buffer'
 124 ;;;                     to perform `forms-first-field' resp. `forms-last-field'.
 125 ;;;
 126 ;;;     forms-new-record-filter                 [symbol, default nil]
 127 ;;;                     If not nil: this should be the name of a
 128 ;;;                     function that is called when a new
 129 ;;;                     record is created.  It can be used to fill in
 130 ;;;                     the new record with default fields, for example.
 131 ;;;
 132 ;;;     forms-modified-record-filter            [symbol, default nil]
 133 ;;;                     If not nil: this should be the name of a
 134 ;;;                     function that is called when a record has
 135 ;;;                     been modified.  It is called after the fields
 136 ;;;                     are parsed.  It can be used to register
 137 ;;;                     modification dates, for example.
 138 ;;;
 139 ;;;     forms-use-text-properties               [bool, see text for default]
 140 ;;;                     This variable controls if forms mode should use
 141 ;;;                     text properties to protect the form text from being
 142 ;;;                     modified (using text-property `read-only').
 143 ;;;                     Also, the read-write fields are shown using a
 144 ;;;                     distinct face, if possible.
 145 ;;;                     This variable defaults to t if running Emacs 19
 146 ;;;                     with text properties.
 147 ;;;                     The default face to show read-write fields is
 148 ;;;                     copied from face `region'.
 149 ;;;
 150 ;;;     forms-ro-face                           [symbol, default 'default]
 151 ;;;                     This is the face that is used to show
 152 ;;;                     read-only text on the screen.If used, this
 153 ;;;                     variable should be set to a symbol that is a
 154 ;;;                     valid face.
 155 ;;;                     E.g.
 156 ;;;                       (make-face 'my-face)
 157 ;;;                       (setq forms-ro-face 'my-face)
 158 ;;;
 159 ;;;     forms-rw-face                           [symbol, default 'region]
 160 ;;;                     This is the face that is used to show
 161 ;;;                     read-write text on the screen.
 162 ;;;
 163 ;;; After evaluating the control file, its buffer is cleared and used
 164 ;;; for further processing.
 165 ;;; The data file (as designated by `forms-file') is visited in a buffer
 166 ;;; `forms--file-buffer' which will not normally be shown.
 167 ;;; Great malfunctioning may be expected if this file/buffer is modified
 168 ;;; outside of this package while it is being visited!
 169 ;;;
 170 ;;; Normal operation is to transfer one line (record) from the data file,
 171 ;;; split it into fields (into `forms--the-record-list'), and display it
 172 ;;; using the specs in `forms-format-list'.
 173 ;;; A format routine `forms--format' is built upon startup to format
 174 ;;; the records according to `forms-format-list'.
 175 ;;;
 176 ;;; When a form is changed the record is updated as soon as this form
 177 ;;; is left.  The contents of the form are parsed using information
 178 ;;; obtained from `forms-format-list', and the fields which are
 179 ;;; deduced from the form are modified.  Fields not shown on the forms
 180 ;;; retain their origional values.  The newly formed record then
 181 ;;; replaces the contents of the old record in `forms--file-buffer'.
 182 ;;; A parse routine `forms--parser' is built upon startup to parse
 183 ;;; the records.
 184 ;;;
 185 ;;; Two exit functions exist: `forms-exit' and `forms-exit-no-save'.
 186 ;;; `forms-exit' saves the data to the file, if modified.
 187 ;;; `forms-exit-no-save` does not.  However, if `forms-exit-no-save'
 188 ;;; is executed and the file buffer has been modified, Emacs will ask
 189 ;;; questions anyway.
 190 ;;;
 191 ;;; Other functions provided by forms mode are:
 192 ;;;
 193 ;;;     paging (forward, backward) by record
 194 ;;;     jumping (first, last, random number)
 195 ;;;     searching
 196 ;;;     creating and deleting records
 197 ;;;     reverting the form (NOT the file buffer)
 198 ;;;     switching edit <-> view mode v.v.
 199 ;;;     jumping from field to field
 200 ;;;
 201 ;;; As an documented side-effect: jumping to the last record in the
 202 ;;; file (using forms-last-record) will adjust forms--total-records if
 203 ;;; needed.
 204 ;;;
 205 ;;; The forms buffer can be in on eof two modes: edit mode or view
 206 ;;; mode.  View mode is a read-only mode, you cannot modify the
 207 ;;; contents of the buffer.
 208 ;;;
 209 ;;; Edit mode commands:
 210 ;;;
 211 ;;; TAB          forms-next-field
 212 ;;; \C-c TAB     forms-next-field
 213 ;;; \C-c <       forms-first-record
 214 ;;; \C-c >       forms-last-record
 215 ;;; \C-c ?       describe-mode
 216 ;;; \C-c \C-k    forms-delete-record
 217 ;;; \C-c \C-q    forms-toggle-read-only
 218 ;;; \C-c \C-o    forms-insert-record
 219 ;;; \C-c \C-l    forms-jump-record
 220 ;;; \C-c \C-n    forms-next-record
 221 ;;; \C-c \C-p    forms-prev-record
 222 ;;; \C-c \C-s    forms-search
 223 ;;; \C-c \C-x    forms-exit
 224 ;;;
 225 ;;; Read-only mode commands:
 226 ;;;
 227 ;;; SPC          forms-next-record
 228 ;;; DEL  forms-prev-record
 229 ;;; ?    describe-mode
 230 ;;; \C-q forms-toggle-read-only
 231 ;;; l    forms-jump-record
 232 ;;; n    forms-next-record
 233 ;;; p    forms-prev-record
 234 ;;; s    forms-search
 235 ;;; x    forms-exit
 236 ;;;
 237 ;;; Of course, it is also possible to use the \C-c prefix to obtain the
 238 ;;; same command keys as in edit mode.
 239 ;;;
 240 ;;; The following bindings are available, independent of the mode:
 241 ;;;
 242 ;;; [next]        forms-next-record
 243 ;;; [prior]       forms-prev-record
 244 ;;; [begin]       forms-first-record
 245 ;;; [end]         forms-last-record
 246 ;;; [S-TAB]       forms-prev-field
 247 ;;; [backtab] forms-prev-field
 248 ;;;
 249 ;;; For convenience, TAB is always bound to `forms-next-field', so you
 250 ;;; don't need the C-c prefix for this command.
 251 ;;;
 252 ;;; As mentioned above (see `forms-forms-scroll' and `forms-forms-jump')
 253 ;;; the bindings of standard functions `scroll-up', `scroll-down',
 254 ;;; `beginning-of-buffer' and `end-of-buffer' can be locally replaced with
 255 ;;; forms mode functions next/prev record and first/last
 256 ;;; record.
 257 ;;;
 258 ;;; `local-write-file hook' is defined to save the actual data file
 259 ;;; instead of the buffer data, `revert-file-hook' is defined to
 260 ;;; revert a forms to original.
 261 \f
 262 ;;; Code:
 263
 264 ;;; Global variables and constants:
 265
 266 (provide 'forms)                        ;;; official
 267 (provide 'forms-mode)                   ;;; for compatibility
 268
 269 (defconst forms-version (substring "$Revision: 2.3 $" 11 -2)
 270   "The version number of forms-mode (as string).  The complete RCS id is:
 271
 272   $Id: forms.el,v 2.3 1993/09/26 14:07:12 jv Exp $")
 273
 274 (defvar forms-mode-hooks nil
 275   "Hook functions to be run upon entering Forms mode.")
 276 \f
 277 ;;; Mandatory variables - must be set by evaluating the control file.
 278
 279 (defvar forms-file nil
 280   "Name of the file holding the data.")
 281
 282 (defvar forms-format-list nil
 283   "List of formatting specifications.")
 284
 285 (defvar forms-number-of-fields nil
 286   "Number of fields per record.")
 287 \f
 288 ;;; Optional variables with default values.
 289
 290 (defvar forms-field-sep "\t"
 291   "Field separator character (default TAB).")
 292
 293 (defvar forms-read-only nil
 294   "Non-nil means: visit the file in view (read-only) mode.
 295 (Defaults to the write access on the data file).")
 296
 297 (defvar forms-multi-line "\C-k"
 298   "If not nil: use this character to separate multi-line fields (default C-k).")
 299
 300 (defvar forms-forms-scroll nil
 301   "*Non-nil means replace scroll-up/down commands in Forms mode.
 302 The replacement commands performs forms-next/prev-record.")
 303
 304 (defvar forms-forms-jump nil
 305   "*Non-nil means redefine beginning/end-of-buffer in Forms mode.
 306 The replacement commands performs forms-first/last-record.")
 307
 308 (defvar forms-new-record-filter nil
 309   "The name of a function that is called when a new record is created.")
 310
 311 (defvar forms-modified-record-filter nil
 312   "The name of a function that is called when a record has been modified.")
 313
 314 (defvar forms-fields nil
 315   "List with fields of the current forms.  First field has number 1.
 316 This variable is for use by the filter routines only.
 317 The contents may NOT be modified.")
 318
 319 (defvar forms-use-text-properties (fboundp 'set-text-properties)
 320   "*Non-nil means: use emacs-19 text properties.
 321 Defaults to t if this emacs is capable of handling text properties.")
 322
 323 (defvar forms-ro-face 'default
 324   "The face (a symbol) that is used to display read-only text on the screen.")
 325
 326 (defvar forms-rw-face 'region
 327   "The face (a symbol) that is used to display read-write text on the screen.")
 328 \f
 329 ;;; Internal variables.
 330
 331 (defvar forms--file-buffer nil
 332   "Buffer which holds the file data")
 333
 334 (defvar forms--total-records 0
 335   "Total number of records in the data file.")
 336
 337 (defvar forms--current-record 0
 338   "Number of the record currently on the screen.")
 339
 340 (defvar forms-mode-map nil
 341    "Keymap for form buffer.")
 342 (defvar forms-mode-ro-map nil
 343    "Keymap for form buffer in view mode.")
 344 (defvar forms-mode-edit-map nil
 345    "Keymap for form buffer in edit mode.")
 346
 347 (defvar forms--markers nil
 348   "Field markers in the screen.")
 349
 350 (defvar forms--dyntexts nil
 351   "Dynamic texts (resulting from function calls) on the screen.")
 352
 353 (defvar forms--the-record-list nil
 354    "List of strings of the current record, as parsed from the file.")
 355
 356 (defvar forms--search-regexp nil
 357   "Last regexp used by forms-search.")
 358
 359 (defvar forms--format nil
 360   "Formatting routine.")
 361
 362 (defvar forms--parser nil
 363   "Forms parser routine.")
 364
 365 (defvar forms--mode-setup nil
 366   "To keep track of forms-mode being set-up.")
 367 (make-variable-buffer-local 'forms--mode-setup)
 368
 369 (defvar forms--dynamic-text nil
 370   "Array that holds dynamic texts to insert between fields.")
 371
 372 (defvar forms--elements nil
 373   "Array with the order in which the fields are displayed.")
 374
 375 (defvar forms--ro-face nil
 376   "Face used to represent read-only data on the screen.")
 377
 378 (defvar forms--rw-face nil
 379   "Face used to represent read-write data on the screen.")
 380 \f
 381 ;;;###autoload
 382 (defun forms-mode (&optional primary)
 383   "Major mode to visit files in a field-structured manner using a form.
 384
 385 Commands:                        Equivalent keys in read-only mode:
 386  TAB            forms-next-field          TAB
 387  \\C-c TAB       forms-next-field
 388  \\C-c <         forms-first-record         <
 389  \\C-c >         forms-last-record          >
 390  \\C-c ?         describe-mode              ?
 391  \\C-c \\C-k      forms-delete-record
 392  \\C-c \\C-q      forms-toggle-read-only     q
 393  \\C-c \\C-o      forms-insert-record
 394  \\C-c \\C-l      forms-jump-record          l
 395  \\C-c \\C-n      forms-next-record          n
 396  \\C-c \\C-p      forms-prev-record          p
 397  \\C-c \\C-s      forms-search               s
 398  \\C-c \\C-x      forms-exit                 x
 399 "
 400   (interactive)
 401
 402   ;; This is not a simple major mode, as usual.  Therefore, forms-mode
 403   ;; takes an optional argument `primary' which is used for the
 404   ;; initial set-up.  Normal use would leave `primary' to nil.
 405   ;; A global buffer-local variable `forms--mode-setup' has the same
 406   ;; effect but makes it possible to auto-invoke forms-mode using
 407   ;; `find-file'.
 408   ;; Note: although it seems logical to have `make-local-variable'
 409   ;; executed where the variable is first needed, I have deliberately
 410   ;; placed all calls in this function.
 411
 412   ;; Primary set-up: evaluate buffer and check if the mandatory
 413   ;; variables have been set.
 414   (if (or primary (not forms--mode-setup))
 415       (progn
 416         ;;(message "forms: setting up...")
 417         (kill-all-local-variables)
 418
 419         ;; Make mandatory variables.
 420         (make-local-variable 'forms-file)
 421         (make-local-variable 'forms-number-of-fields)
 422         (make-local-variable 'forms-format-list)
 423
 424         ;; Make optional variables.
 425         (make-local-variable 'forms-field-sep)
 426         (make-local-variable 'forms-read-only)
 427         (make-local-variable 'forms-multi-line)
 428         (make-local-variable 'forms-forms-scroll)
 429         (make-local-variable 'forms-forms-jump)
 430         (make-local-variable 'forms-use-text-properties)
 431         (make-local-variable 'forms-new-record-filter)
 432         (make-local-variable 'forms-modified-record-filter)
 433
 434         ;; Make sure no filters exist.
 435         (setq forms-new-record-filter nil)
 436         (setq forms-modified-record-filter nil)
 437
 438         ;; If running Emacs 19 under X, setup faces to show read-only and
 439         ;; read-write fields.
 440         (if (fboundp 'make-face)
 441             (progn
 442               (make-local-variable 'forms-ro-face)
 443               (make-local-variable 'forms-rw-face)))
 444
 445         ;; eval the buffer, should set variables
 446         ;;(message "forms: processing control file...")
 447         (eval-current-buffer)
 448
 449         ;; check if the mandatory variables make sense.
 450         (or forms-file
 451             (error (concat "Forms control file error: "
 452                            "'forms-file' has not been set")))
 453         (or forms-number-of-fields
 454             (error (concat "Forms control file error: "
 455                            "'forms-number-of-fields' has not been set")))
 456         (or (and (numberp forms-number-of-fields)
 457                  (> forms-number-of-fields 0))
 458             (error (concat "Forms control file error: "
 459                            "'forms-number-of-fields' must be a number > 0")))
 460         (or (stringp forms-field-sep)
 461             (error (concat "Forms control file error: "
 462                            "'forms-field-sep' is not a string")))
 463         (if forms-multi-line
 464             (if (and (stringp forms-multi-line)
 465                      (eq (length forms-multi-line) 1))
 466                 (if (string= forms-multi-line forms-field-sep)
 467                     (error (concat "Forms control file error: "
 468                                    "'forms-multi-line' is equal to 'forms-field-sep'")))
 469               (error (concat "Forms control file error: "
 470                              "'forms-multi-line' must be nil or a one-character string"))))
 471         (or (fboundp 'set-text-properties)
 472             (setq forms-use-text-properties nil))
 473
 474         ;; Validate and process forms-format-list.
 475         ;;(message "forms: pre-processing format list...")
 476         (forms--process-format-list)
 477
 478         ;; Build the formatter and parser.
 479         ;;(message "forms: building formatter...")
 480         (make-local-variable 'forms--format)
 481         (make-local-variable 'forms--markers)
 482         (make-local-variable 'forms--dyntexts)
 483         (make-local-variable 'forms--elements)
 484         ;;(message "forms: building parser...")
 485         (forms--make-format)
 486         (make-local-variable 'forms--parser)
 487         (forms--make-parser)
 488         ;;(message "forms: building parser... done.")
 489
 490         ;; Check if record filters are defined.
 491         (if (and forms-new-record-filter
 492                  (not (fboundp forms-new-record-filter)))
 493             (error (concat "Forms control file error: "
 494                            "'forms-new-record-filter' is not a function")))
 495
 496         (if (and forms-modified-record-filter
 497                  (not (fboundp forms-modified-record-filter)))
 498             (error (concat "Forms control file error: "
 499                            "'forms-modified-record-filter' is not a function")))
 500
 501         ;; The filters acces the contents of the forms using `forms-fields'.
 502         (make-local-variable 'forms-fields)
 503
 504         ;; Dynamic text support.
 505         (make-local-variable 'forms--dynamic-text)
 506
 507         ;; Prevent accidental overwrite of the control file and autosave.
 508         (setq buffer-file-name nil)
 509         (auto-save-mode nil)
 510
 511         ;; Prepare this buffer for further processing.
 512         (setq buffer-read-only nil)
 513         (erase-buffer)
 514
 515         ;;(message "forms: setting up... done.")
 516         ))
 517
 518   ;; Copy desired faces to the actual variables used by the forms formatter.
 519   (if (fboundp 'make-face)
 520       (progn
 521         (make-local-variable 'forms--ro-face)
 522         (make-local-variable 'forms--rw-face)
 523         (if forms-read-only
 524             (progn
 525               (setq forms--ro-face forms-ro-face)
 526               (setq forms--rw-face forms-ro-face))
 527           (setq forms--ro-face forms-ro-face)
 528           (setq forms--rw-face forms-rw-face))))
 529
 530   ;; Make more local variables.
 531   (make-local-variable 'forms--file-buffer)
 532   (make-local-variable 'forms--total-records)
 533   (make-local-variable 'forms--current-record)
 534   (make-local-variable 'forms--the-record-list)
 535   (make-local-variable 'forms--search-regexp)
 536
 537   ; The keymaps are global, so multiple forms mode buffers can share them.
 538   ;(make-local-variable 'forms-mode-map)
 539   ;(make-local-variable 'forms-mode-ro-map)
 540   ;(make-local-variable 'forms-mode-edit-map)
 541   (if forms-mode-map                    ; already defined
 542       nil
 543     ;;(message "forms: building keymap...")
 544     (forms--mode-commands)
 545     ;;(message "forms: building keymap... done.")
 546     )
 547
 548   ;; find the data file
 549   (setq forms--file-buffer (find-file-noselect forms-file))
 550
 551   ;; count the number of records, and set see if it may be modified
 552   (let (ro)
 553     (setq forms--total-records
 554           (save-excursion
 555             (prog1
 556                 (progn
 557                   ;;(message "forms: counting records...")
 558                   (set-buffer forms--file-buffer)
 559                   (bury-buffer (current-buffer))
 560                   (setq ro buffer-read-only)
 561                   (count-lines (point-min) (point-max)))
 562               ;;(message "forms: counting records... done.")
 563               )))
 564     (if ro
 565         (setq forms-read-only t)))
 566
 567   ;;(message "forms: proceeding setup...")
 568   ;; set the major mode indicator
 569   (setq major-mode 'forms-mode)
 570   (setq mode-name "Forms")
 571   (make-local-variable 'minor-mode-alist) ; needed?
 572   ;;(message "forms: proceeding setup (minor mode)...")
 573   (forms--set-minor-mode)
 574   ;;(message "forms: proceeding setup (keymaps)...")
 575   (forms--set-keymaps)
 576   ;;(message "forms: proceeding setup (commands)...")
 577   (forms--change-commands)
 578
 579   ;;(message "forms: proceeding setup (buffer)...")
 580   (set-buffer-modified-p nil)
 581
 582   ;; setup the first (or current) record to show
 583   (if (< forms--current-record 1)
 584       (setq forms--current-record 1))
 585   (forms-jump-record forms--current-record)
 586
 587   ;; user customising
 588   ;;(message "forms: proceeding setup (user hooks)...")
 589   (run-hooks 'forms-mode-hooks)
 590   ;;(message "forms: setting up... done.")
 591
 592   ;; be helpful
 593   (forms--help)
 594
 595   ;; initialization done
 596   (setq forms--mode-setup t))
 597 \f
 598 (defun forms--process-format-list ()
 599   ;; Validate `forms-format-list' and set some global variables.
 600   ;; Symbols in the list are evaluated, and consecutive strings are
 601   ;; concatenated.
 602   ;; Array `forms--elements' is constructed that contains the order
 603   ;; of the fields on the display. This array is used by
 604   ;; `forms--parser-using-text-properties' to extract the fields data
 605   ;; from the form on the screen.
 606   ;; Upon completion, `forms-format-list' is garanteed correct, so
 607   ;; `forms--make-format' and `forms--make-parser' do not need to perform
 608   ;; any checks.
 609
 610   ;; Verify that `forms-format-list' is not nil.
 611   (or forms-format-list
 612       (error (concat "Forms control file error: "
 613                      "'forms-format-list' has not been set")))
 614   ;; It must be a list.
 615   (or (listp forms-format-list)
 616       (error (concat "Forms control file error: "
 617                      "'forms-format-list' is not a list")))
 618
 619   ;; Assume every field is painted once.
 620   ;; `forms--elements' will grow if needed.
 621   (setq forms--elements (make-vector forms-number-of-fields nil))
 622
 623   (let ((the-list forms-format-list)    ; the list of format elements
 624         (this-item 0)                   ; element in list
 625         (prev-item nil)
 626         (field-num 0))                  ; highest field number
 627
 628     (setq forms-format-list nil)        ; gonna rebuild
 629
 630     (while the-list
 631
 632       (let ((el (car-safe the-list))
 633             (rem (cdr-safe the-list)))
 634
 635         ;; If it is a symbol, eval it first.
 636         (if (and (symbolp el)
 637                  (boundp el))
 638             (setq el (eval el)))
 639
 640         (cond
 641
 642          ;; Try string ...
 643          ((stringp el)
 644           (if (stringp prev-item)       ; try to concatenate strings
 645               (setq prev-item (concat prev-item el))
 646             (if prev-item
 647                 (setq forms-format-list
 648                       (append forms-format-list (list prev-item) nil)))
 649             (setq prev-item el)))
 650
 651          ;; Try numeric ...
 652          ((numberp el)
 653
 654           ;; Validate range.
 655           (if (or (<= el 0)
 656                   (> el forms-number-of-fields))
 657               (error (concat "Forms format error: "
 658                              "field number %d out of range 1..%d")
 659                      el forms-number-of-fields))
 660
 661           ;; Store forms order.
 662           (if (> field-num (length forms--elements))
 663               (setq forms--elements (vconcat forms--elements (1- el)))
 664             (aset forms--elements field-num (1- el)))
 665           (setq field-num (1+ field-num))
 666
 667           (if prev-item
 668               (setq forms-format-list
 669                     (append forms-format-list (list prev-item) nil)))
 670           (setq prev-item el))
 671
 672          ;; Try function ...
 673          ((listp el)
 674
 675           ;; Validate.
 676           (or (fboundp (car-safe el))
 677               (error (concat "Forms format error: "
 678                              "not a function "
 679                              (prin1-to-string (car-safe el)))))
 680
 681           ;; Shift.
 682           (if prev-item
 683               (setq forms-format-list
 684                     (append forms-format-list (list prev-item) nil)))
 685           (setq prev-item el))
 686
 687          ;; else
 688          (t
 689           (error (concat "Forms format error: "
 690                          "invalid element "
 691                          (prin1-to-string el)))))
 692
 693         ;; Advance to next element of the list.
 694         (setq the-list rem)))
 695
 696     ;; Append last item.
 697     (if prev-item
 698         (progn
 699           (setq forms-format-list
 700                 (append forms-format-list (list prev-item) nil))
 701           ;; Append a newline if the last item is a field.
 702           ;; This prevents parsing problems.
 703           ;; Also it makes it possible to insert an empty last field.
 704           (if (numberp prev-item)
 705               (setq forms-format-list
 706                     (append forms-format-list (list "\n") nil))))))
 707
 708   (forms--debug 'forms-format-list
 709                 'forms--elements))
 710 \f
 711 ;; Special treatment for read-only segments.
 712 ;;
 713 ;; If text is inserted between two read-only segments, it inherits the
 714 ;; read-only properties.  This is not what we want.
 715 ;; To solve this, read-only segments get the `insert-in-front-hooks'
 716 ;; property set with a function that temporarily switches the properties
 717 ;; of the first character of the segment to read-write, so the new
 718 ;; text gets the right properties.
 719 ;; The `post-command-hook' is used to restore the original properties.
 720
 721 (defvar forms--iif-start nil
 722   "Record start of modification command.")
 723 (defvar forms--iif-properties nil
 724   "Original properties of the character being overridden.")
 725
 726 (defun forms--iif-hook (begin end)
 727   "`insert-in-front-hooks' function for read-only segments."
 728
 729   ;; Note start location.  By making it a marker that points one
 730   ;; character beyond the actual location, it is guaranteed to move
 731   ;; correctly if text is inserted.
 732   (or forms--iif-start
 733       (setq forms--iif-start (copy-marker (1+ (point)))))
 734
 735   ;; Check if there is special treatment required.
 736   (if (or (<= forms--iif-start 2)
 737           (get-text-property (- forms--iif-start 2)
 738                              'read-only))
 739       (progn
 740         ;; Fetch current properties.
 741         (setq forms--iif-properties
 742               (text-properties-at (1- forms--iif-start)))
 743
 744         ;; Replace them.
 745         (let ((inhibit-read-only t))
 746           (set-text-properties
 747            (1- forms--iif-start) forms--iif-start
 748            (list 'face forms--rw-face 'front-sticky '(face))))
 749
 750         ;; Enable `post-command-hook' to restore the properties.
 751         (setq post-command-hook
 752               (append (list 'forms--iif-post-command-hook) post-command-hook)))
 753
 754     ;; No action needed.  Clear marker.
 755     (setq forms--iif-start nil)))
 756
 757 (defun forms--iif-post-command-hook ()
 758   "`post-command-hook' function for read-only segments."
 759
 760   ;; Disable `post-command-hook'.
 761   (setq post-command-hook
 762         (delq 'forms--iif-hook-post-command-hook post-command-hook))
 763
 764   ;; Restore properties.
 765   (if forms--iif-start
 766       (let ((inhibit-read-only t))
 767         (set-text-properties
 768          (1- forms--iif-start) forms--iif-start
 769          forms--iif-properties)))
 770
 771   ;; Cleanup.
 772   (setq forms--iif-start nil))
 773 \f
 774 (defvar forms--marker)
 775 (defvar forms--dyntext)
 776
 777 (defun forms--make-format ()
 778   "Generate `forms--format' using the information in `forms-format-list'."
 779
 780   ;; The real work is done using a mapcar of `forms--make-format-elt' on
 781   ;; `forms-format-list'.
 782   ;; This function sets up the necessary environment, and decides
 783   ;; which function to mapcar.
 784
 785   (let ((forms--marker 0)
 786         (forms--dyntext 0))
 787     (setq
 788      forms--format
 789      (if forms-use-text-properties
 790          (` (lambda (arg)
 791               (let ((inhibit-read-only t))
 792                 (,@ (apply 'append
 793                            (mapcar 'forms--make-format-elt-using-text-properties
 794                                    forms-format-list)))
 795                 ;; Prevent insertion before the first text.
 796                 (,@ (if (numberp (car forms-format-list))
 797                         nil
 798                       '((add-text-properties (point-min) (1+ (point-min))
 799                                              '(front-sticky (read-only))))))
 800                 ;; Prevent insertion after the last text.
 801                 (remove-text-properties (1- (point)) (point)
 802                                         '(rear-nonsticky)))
 803               (setq forms--iif-start nil)))
 804        (` (lambda (arg)
 805             (,@ (apply 'append
 806                        (mapcar 'forms--make-format-elt forms-format-list)))))))
 807
 808     ;; We have tallied the number of markers and dynamic texts,
 809     ;; so we can allocate the arrays now.
 810     (setq forms--markers (make-vector forms--marker nil))
 811     (setq forms--dyntexts (make-vector forms--dyntext nil)))
 812   (forms--debug 'forms--format))
 813
 814 (defun forms--make-format-elt-using-text-properties (el)
 815   "Helper routine to generate format function."
 816
 817   ;; The format routine `forms--format' will look like
 818   ;;
 819   ;; ;; preamble
 820   ;; (lambda (arg)
 821   ;;   (let ((inhibit-read-only t))
 822   ;;
 823   ;;     ;; A string, e.g. "text: ".
 824   ;;     (set-text-properties
 825   ;;      (point)
 826   ;;      (progn (insert "text: ") (point))
 827   ;;      (list 'face forms--ro-face
 828   ;;            'read-only 1
 829   ;;            'insert-in-front-hooks 'forms--iif-hook
 830   ;;            'rear-nonsticky '(read-only face insert-in-front-hooks)))
 831   ;;
 832   ;;     ;; A field, e.g. 6.
 833   ;;     (let ((here (point)))
 834   ;;       (aset forms--markers 0 (point-marker))
 835   ;;       (insert (elt arg 5))
 836   ;;       (or (= (point) here)
 837   ;;      (set-text-properties
 838   ;;       here (point)
 839   ;;       (list 'face forms--rw-face
 840   ;;             'front-sticky '(face))))
 841   ;;
 842   ;;     ;; Another string, e.g. "\nmore text: ".
 843   ;;     (set-text-properties
 844   ;;      (point)
 845   ;;      (progn (insert "\nmore text: ") (point))
 846   ;;      (list 'face forms--ro-face
 847   ;;            'read-only 2
 848   ;;            'insert-in-front-hooks 'forms--iif-hook
 849   ;;            'rear-nonsticky '(read-only face insert-in-front-hooks)))
 850   ;;
 851   ;;     ;; A function, e.g. (tocol 40).
 852   ;;     (set-text-properties
 853   ;;      (point)
 854   ;;      (progn
 855   ;;        (insert (aset forms--dyntexts 0 (tocol 40)))
 856   ;;        (point))
 857   ;;      (list 'face forms--ro-face
 858   ;;            'read-only 2
 859   ;;            'insert-in-front-hooks 'forms--iif-hook
 860   ;;            'rear-nonsticky '(read-only face insert-in-front-hooks)))
 861   ;;
 862   ;;     ;; Prevent insertion before the first text.
 863   ;;     (add-text-properties (point-min) (1+ (point-min))
 864   ;;                          '(front-sticky (read-only))))))
 865   ;;     ;; Prevent insertion after the last text.
 866   ;;     (remove-text-properties (1- (point)) (point)
 867   ;;                             '(rear-nonsticky)))
 868   ;;
 869   ;;     ;; wrap up
 870   ;;     (setq forms--iif-start nil)
 871   ;;     ))
 872
 873   (cond
 874    ((stringp el)
 875
 876     (` ((set-text-properties
 877          (point)                        ; start at point
 878          (progn                         ; until after insertion
 879            (insert (, el))
 880            (point))
 881          (list 'face forms--ro-face     ; read-only appearance
 882                'read-only (,@ (list (1+ forms--marker)))
 883                'insert-in-front-hooks '(forms--iif-hook)
 884                'rear-nonsticky '(face read-only insert-in-front-hooks))))))
 885
 886    ((numberp el)
 887     (` ((let ((here (point)))
 888           (aset forms--markers
 889                 (, (prog1 forms--marker
 890                      (setq forms--marker (1+ forms--marker))))
 891                 (point-marker))
 892           (insert (elt arg (, (1- el))))
 893           (or (= (point) here)
 894               (set-text-properties
 895                here (point)
 896                (list 'face forms--rw-face
 897                      'front-sticky '(face))))))))
 898
 899    ((listp el)
 900     (` ((set-text-properties
 901          (point)
 902          (progn
 903            (insert (aset forms--dyntexts
 904                          (, (prog1 forms--dyntext
 905                               (setq forms--dyntext (1+ forms--dyntext))))
 906                          (, el)))
 907            (point))
 908          (list 'face forms--ro-face
 909                'read-only (,@ (list (1+ forms--marker)))
 910                'insert-in-front-hooks '(forms--iif-hook)
 911                'rear-nonsticky '(read-only face insert-in-front-hooks))))))
 912
 913    ;; end of cond
 914    ))
 915
 916 (defun forms--make-format-elt (el)
 917   "Helper routine to generate format function."
 918
 919   ;; If we're not using text properties, the format routine
 920   ;; `forms--format' will look like
 921   ;;
 922   ;; (lambda (arg)
 923   ;;   ;; a string, e.g. "text: "
 924   ;;   (insert "text: ")
 925   ;;   ;; a field, e.g. 6
 926   ;;   (aset forms--markers 0 (point-marker))
 927   ;;   (insert (elt arg 5))
 928   ;;   ;; another string, e.g. "\nmore text: "
 929   ;;   (insert "\nmore text: ")
 930   ;;   ;; a function, e.g. (tocol 40)
 931   ;;   (insert (aset forms--dyntexts 0 (tocol 40)))
 932   ;;   ... )
 933
 934   (cond
 935    ((stringp el)
 936     (` ((insert (, el)))))
 937    ((numberp el)
 938     (prog1
 939         (` ((aset forms--markers (, forms--marker) (point-marker))
 940             (insert (elt arg (, (1- el))))))
 941       (setq forms--marker (1+ forms--marker))))
 942    ((listp el)
 943     (prog1
 944         (` ((insert (aset forms--dyntexts (, forms--dyntext) (, el)))))
 945       (setq forms--dyntext (1+ forms--dyntext))))))
 946 \f
 947 (defvar forms--field)
 948 (defvar forms--recordv)
 949 (defvar forms--seen-text)
 950
 951 (defun forms--make-parser ()
 952   "Generate `forms--parser' from the information in `forms-format-list'."
 953
 954   ;; If we can use text properties, we simply set it to
 955   ;; `forms--parser-using-text-properties'.
 956   ;; Otherwise, the function is constructed using a mapcar of
 957   ;; `forms--make-parser-elt on `forms-format-list'.
 958
 959   (setq
 960    forms--parser
 961    (if forms-use-text-properties
 962        (function forms--parser-using-text-properties)
 963      (let ((forms--field nil)
 964            (forms--seen-text nil)
 965            (forms--dyntext 0))
 966
 967        ;; Note: we add a nil element to the list passed to `mapcar',
 968        ;; see `forms--make-parser-elt' for details.
 969        (` (lambda nil
 970             (let (here)
 971               (goto-char (point-min))
 972               (,@ (apply 'append
 973                          (mapcar
 974                           'forms--make-parser-elt
 975                           (append forms-format-list (list nil)))))))))))
 976
 977   (forms--debug 'forms--parser))
 978
 979 (defun forms--parser-using-text-properties ()
 980   "Extract field info from forms when using text properties."
 981
 982   ;; Using text properties, we can simply jump to the markers, and
 983   ;; extract the information up to the following read-only segment.
 984
 985   (let ((i 0)
 986         here there)
 987     (while (< i (length forms--markers))
 988       (goto-char (setq here (aref forms--markers i)))
 989       (if (get-text-property here 'read-only)
 990           (aset forms--recordv (aref forms--elements i) nil)
 991         (if (setq there
 992                   (next-single-property-change here 'read-only))
 993             (aset forms--recordv (aref forms--elements i)
 994                   (buffer-substring here there))
 995           (aset forms--recordv (aref forms--elements i)
 996                 (buffer-substring here (point-max)))))
 997       (setq i (1+ i)))))
 998
 999 (defun forms--make-parser-elt (el)
1000   "Helper routine to generate forms parser function."
1001
1002   ;; The parse routine will look like:
1003   ;;
1004   ;; (lambda nil
1005   ;;   (let (here)
1006   ;;     (goto-char (point-min))
1007   ;;
1008   ;;     ;;  "text: "
1009   ;;     (if (not (looking-at "text: "))
1010   ;;        (error "Parse error: cannot find \"text: \""))
1011   ;;     (forward-char 6)       ; past "text: "
1012   ;;
1013   ;;     ;;  6
1014   ;;     ;;  "\nmore text: "
1015   ;;     (setq here (point))
1016   ;;     (if (not (search-forward "\nmore text: " nil t nil))
1017   ;;        (error "Parse error: cannot find \"\\nmore text: \""))
1018   ;;     (aset forms--recordv 5 (buffer-substring here (- (point) 12)))
1019   ;;
1020   ;;     ;;  (tocol 40)
1021   ;;    (let ((forms--dyntext (car-safe forms--dynamic-text)))
1022   ;;      (if (not (looking-at (regexp-quote forms--dyntext)))
1023   ;;          (error "Parse error: not looking at \"%s\"" forms--dyntext))
1024   ;;      (forward-char (length forms--dyntext))
1025   ;;      (setq forms--dynamic-text (cdr-safe forms--dynamic-text)))
1026   ;;     ...
1027   ;;     ;; final flush (due to terminator sentinel, see below)
1028   ;;    (aset forms--recordv 7 (buffer-substring (point) (point-max)))
1029
1030   (cond
1031    ((stringp el)
1032     (prog1
1033         (if forms--field
1034             (` ((setq here (point))
1035                 (if (not (search-forward (, el) nil t nil))
1036                     (error "Parse error: cannot find \"%s\"" (, el)))
1037                 (aset forms--recordv (, (1- forms--field))
1038                       (buffer-substring here
1039                                         (- (point) (, (length el)))))))
1040           (` ((if (not (looking-at (, (regexp-quote el))))
1041                   (error "Parse error: not looking at \"%s\"" (, el)))
1042               (forward-char (, (length el))))))
1043       (setq forms--seen-text t)
1044       (setq forms--field nil)))
1045    ((numberp el)
1046     (if forms--field
1047         (error "Cannot parse adjacent fields %d and %d"
1048                forms--field el)
1049       (setq forms--field el)
1050       nil))
1051    ((null el)
1052     (if forms--field
1053         (` ((aset forms--recordv (, (1- forms--field))
1054                   (buffer-substring (point) (point-max)))))))
1055    ((listp el)
1056     (prog1
1057         (if forms--field
1058             (` ((let ((here (point))
1059                       (forms--dyntext (aref forms--dyntexts (, forms--dyntext))))
1060                   (if (not (search-forward forms--dyntext nil t nil))
1061                       (error "Parse error: cannot find \"%s\"" forms--dyntext))
1062                   (aset forms--recordv (, (1- forms--field))
1063                         (buffer-substring here
1064                                           (- (point) (length forms--dyntext)))))))
1065           (` ((let ((forms--dyntext (aref forms--dyntexts (, forms--dyntext))))
1066                 (if (not (looking-at (regexp-quote forms--dyntext)))
1067                     (error "Parse error: not looking at \"%s\"" forms--dyntext))
1068                 (forward-char (length forms--dyntext))))))
1069       (setq forms--dyntext (1+ forms--dyntext))
1070       (setq forms--seen-text t)
1071       (setq forms--field nil)))
1072    ))
1073 \f
1074 (defun forms--set-minor-mode ()
1075   (setq minor-mode-alist
1076         (if forms-read-only
1077             " View"
1078           nil)))
1079
1080 (defun forms--set-keymaps ()
1081   "Set the keymaps used in this mode."
1082
1083   (use-local-map (if forms-read-only
1084                      forms-mode-ro-map
1085                    forms-mode-edit-map)))
1086
1087 (defun forms--mode-commands ()
1088   "Fill the Forms mode keymaps."
1089
1090   ;; `forms-mode-map' is always accessible via \C-c prefix.
1091   (setq forms-mode-map (make-keymap))
1092   (define-key forms-mode-map "\t" 'forms-next-field)
1093   (define-key forms-mode-map "\C-k" 'forms-delete-record)
1094   (define-key forms-mode-map "\C-q" 'forms-toggle-read-only)
1095   (define-key forms-mode-map "\C-o" 'forms-insert-record)
1096   (define-key forms-mode-map "\C-l" 'forms-jump-record)
1097   (define-key forms-mode-map "\C-n" 'forms-next-record)
1098   (define-key forms-mode-map "\C-p" 'forms-prev-record)
1099   (define-key forms-mode-map "\C-s" 'forms-search)
1100   (define-key forms-mode-map "\C-x" 'forms-exit)
1101   (define-key forms-mode-map "<" 'forms-first-record)
1102   (define-key forms-mode-map ">" 'forms-last-record)
1103   (define-key forms-mode-map "?" 'describe-mode)
1104   (define-key forms-mode-map "\C-?" 'forms-prev-record)
1105
1106   ;; `forms-mode-ro-map' replaces the local map when in read-only mode.
1107   (setq forms-mode-ro-map (make-keymap))
1108   (suppress-keymap forms-mode-ro-map)
1109   (define-key forms-mode-ro-map "\C-c" forms-mode-map)
1110   (define-key forms-mode-ro-map "\t" 'forms-next-field)
1111   (define-key forms-mode-ro-map "q" 'forms-toggle-read-only)
1112   (define-key forms-mode-ro-map "l" 'forms-jump-record)
1113   (define-key forms-mode-ro-map "n" 'forms-next-record)
1114   (define-key forms-mode-ro-map "p" 'forms-prev-record)
1115   (define-key forms-mode-ro-map "s" 'forms-search)
1116   (define-key forms-mode-ro-map "x" 'forms-exit)
1117   (define-key forms-mode-ro-map "<" 'forms-first-record)
1118   (define-key forms-mode-ro-map ">" 'forms-last-record)
1119   (define-key forms-mode-ro-map "?" 'describe-mode)
1120   (define-key forms-mode-ro-map " " 'forms-next-record)
1121   (forms--mode-commands1 forms-mode-ro-map)
1122
1123   ;; This is the normal, local map.
1124   (setq forms-mode-edit-map (make-keymap))
1125   (define-key forms-mode-edit-map "\t"   'forms-next-field)
1126   (define-key forms-mode-edit-map "\C-c" forms-mode-map)
1127   (forms--mode-commands1 forms-mode-edit-map)
1128   )
1129
1130 (defun forms--mode-commands1 (map)
1131   "Helper routine to define keys."
1132   (define-key map [TAB] 'forms-next-field)
1133   (define-key map [S-tab] 'forms-prev-field)
1134   (define-key map [next] 'forms-next-record)
1135   (define-key map [prior] 'forms-prev-record)
1136   (define-key map [begin] 'forms-first-record)
1137   (define-key map [last] 'forms-last-record)
1138   (define-key map [backtab] 'forms-prev-field)
1139   )
1140 \f
1141 ;;; Changed functions
1142
1143 (defun forms--change-commands ()
1144   "Localize some commands for Forms mode."
1145
1146   ;; scroll-down -> forms-prev-record
1147   ;; scroll-up -> forms-next-record
1148   (if forms-forms-scroll
1149       (progn
1150         (substitute-key-definition 'scroll-up 'forms-next-record
1151                                    (current-local-map)
1152                                    (current-global-map))
1153         (substitute-key-definition 'scroll-down 'forms-prev-record
1154                                    (current-local-map)
1155                                    (current-global-map))))
1156   ;;
1157   ;; beginning-of-buffer -> forms-first-record
1158   ;; end-of-buffer -> forms-end-record
1159   (if forms-forms-jump
1160       (progn
1161         (substitute-key-definition 'beginning-of-buffer 'forms-first-record
1162                                    (current-local-map)
1163                                    (current-global-map))
1164         (substitute-key-definition 'end-of-buffer 'forms-last-record
1165                                    (current-local-map)
1166                                    (current-global-map))))
1167   ;;
1168   ;; save-buffer -> forms--save-buffer
1169   (make-local-variable 'local-write-file-hooks)
1170   (add-hook 'local-write-file-hooks
1171             (function
1172              (lambda (nil)
1173                (forms--checkmod)
1174                (save-excursion
1175                  (set-buffer forms--file-buffer)
1176                  (save-buffer))
1177                t)))
1178   ;; We have our own revert function - use it
1179   (make-local-variable 'revert-buffer-function)
1180   (setq revert-buffer-function 'forms-revert-buffer)
1181
1182   t)
1183
1184 (defun forms--help ()
1185   "Initial help for Forms mode."
1186   ;; We should use
1187   (message (substitute-command-keys (concat
1188   "\\[forms-next-record]:next"
1189   "   \\[forms-prev-record]:prev"
1190   "   \\[forms-first-record]:first"
1191   "   \\[forms-last-record]:last"
1192   "   \\[describe-mode]:help"))))
1193   ; but it's too slow ....
1194 ;  (if forms-read-only
1195 ;      (message "SPC:next   DEL:prev   <:first   >:last   ?:help   q:exit")
1196 ;    (message "C-c n:next   C-c p:prev   C-c <:first   C-c >:last   C-c ?:help   C-c q:exit"))
1197 ;  )
1198
1199 (defun forms--trans (subj arg rep)
1200   "Translate in SUBJ all chars ARG into char REP.  ARG and REP should
1201  be single-char strings."
1202   (let ((i 0)
1203         (x (length subj))
1204         (re (regexp-quote arg))
1205         (k (string-to-char rep)))
1206     (while (setq i (string-match re subj i))
1207       (aset subj i k)
1208       (setq i (1+ i)))))
1209
1210 (defun forms--exit (query &optional save)
1211   "Internal exit from forms mode function."
1212
1213   (let ((buf (buffer-name forms--file-buffer)))
1214     (forms--checkmod)
1215     (if (and save
1216              (buffer-modified-p forms--file-buffer))
1217         (save-excursion
1218           (set-buffer forms--file-buffer)
1219           (save-buffer)))
1220     (save-excursion
1221       (set-buffer forms--file-buffer)
1222       (delete-auto-save-file-if-necessary)
1223       (kill-buffer (current-buffer)))
1224     (if (get-buffer buf)        ; not killed???
1225       (if save
1226           (progn
1227             (beep)
1228             (message "Problem saving buffers?")))
1229       (delete-auto-save-file-if-necessary)
1230       (kill-buffer (current-buffer)))))
1231
1232 (defun forms--get-record ()
1233   "Fetch the current record from the file buffer."
1234
1235   ;; This function is executed in the context of the `forms--file-buffer'.
1236
1237   (or (bolp)
1238       (beginning-of-line nil))
1239   (let ((here (point)))
1240     (prog2
1241      (end-of-line)
1242      (buffer-substring here (point))
1243      (goto-char here))))
1244
1245 (defun forms--show-record (the-record)
1246   "Format THE-RECORD and display it in the current buffer."
1247
1248   ;; Split the-record.
1249   (let (the-result
1250         (start-pos 0)
1251         found-pos
1252         (field-sep-length (length forms-field-sep)))
1253     (if forms-multi-line
1254         (forms--trans the-record forms-multi-line "\n"))
1255     ;; Add an extra separator (makes splitting easy).
1256     (setq the-record (concat the-record forms-field-sep))
1257     (while (setq found-pos (string-match forms-field-sep the-record start-pos))
1258       (let ((ent (substring the-record start-pos found-pos)))
1259         (setq the-result
1260               (append the-result (list ent)))
1261         (setq start-pos (+ field-sep-length found-pos))))
1262     (setq forms--the-record-list the-result))
1263
1264   (setq buffer-read-only nil)
1265   (if forms-use-text-properties
1266       (let ((inhibit-read-only t))
1267         (set-text-properties (point-min) (point-max) nil)))
1268   (erase-buffer)
1269
1270   ;; Verify the number of fields, extend forms--the-record-list if needed.
1271   (if (= (length forms--the-record-list) forms-number-of-fields)
1272       nil
1273     (beep)
1274     (message "Warning: this record has %d fields instead of %d"
1275              (length forms--the-record-list) forms-number-of-fields)
1276     (if (< (length forms--the-record-list) forms-number-of-fields)
1277         (setq forms--the-record-list
1278               (append forms--the-record-list
1279                       (make-list
1280                        (- forms-number-of-fields
1281                           (length forms--the-record-list))
1282                        "")))))
1283
1284   ;; Call the formatter function.
1285   (setq forms-fields (append (list nil) forms--the-record-list nil))
1286   (funcall forms--format forms--the-record-list)
1287
1288   ;; Prepare.
1289   (goto-char (point-min))
1290   (set-buffer-modified-p nil)
1291   (setq buffer-read-only forms-read-only)
1292   (setq mode-line-process
1293         (concat " " forms--current-record "/" forms--total-records)))
1294
1295 (defun forms--parse-form ()
1296   "Parse contents of form into list of strings."
1297   ;; The contents of the form are parsed, and a new list of strings
1298   ;; is constructed.
1299   ;; A vector with the strings from the original record is
1300   ;; constructed, which is updated with the new contents.  Therefore
1301   ;; fields which were not in the form are not modified.
1302   ;; Finally, the vector is transformed into a list for further processing.
1303
1304   (let (forms--recordv)
1305
1306     ;; Build the vector.
1307     (setq forms--recordv (vconcat forms--the-record-list))
1308
1309     ;; Parse the form and update the vector.
1310     (let ((forms--dynamic-text forms--dynamic-text))
1311       (funcall forms--parser))
1312
1313     (if forms-modified-record-filter
1314         ;; As a service to the user, we add a zeroth element so she
1315         ;; can use the same indices as in the forms definition.
1316         (let ((the-fields (vconcat [nil] forms--recordv)))
1317           (setq the-fields (funcall forms-modified-record-filter the-fields))
1318           (cdr (append the-fields nil)))
1319
1320       ;; Transform to a list and return.
1321       (append forms--recordv nil))))
1322
1323 (defun forms--update ()
1324   "Update current record with contents of form.
1325 As a side effect: sets `forms--the-record-list'."
1326
1327   (if forms-read-only
1328       (progn
1329         (message "Read-only buffer!")
1330         (beep))
1331
1332     (let (the-record)
1333       ;; Build new record.
1334       (setq forms--the-record-list (forms--parse-form))
1335       (setq the-record
1336             (mapconcat 'identity forms--the-record-list forms-field-sep))
1337
1338       ;; Handle multi-line fields, if allowed.
1339       (if forms-multi-line
1340           (forms--trans the-record "\n" forms-multi-line))
1341
1342       ;; A final sanity check before updating.
1343       (if (string-match "\n" the-record)
1344           (progn
1345             (message "Multi-line fields in this record - update refused!")
1346             (beep))
1347
1348         (save-excursion
1349           (set-buffer forms--file-buffer)
1350           ;; Use delete-region instead of kill-region, to avoid
1351           ;; adding junk to the kill-ring.
1352           (delete-region (save-excursion (beginning-of-line) (point))
1353                          (save-excursion (end-of-line) (point)))
1354           (insert the-record)
1355           (beginning-of-line))))))
1356
1357 (defun forms--checkmod ()
1358   "Check if this form has been modified, and call forms--update if so."
1359   (if (buffer-modified-p nil)
1360       (let ((here (point)))
1361         (forms--update)
1362         (set-buffer-modified-p nil)
1363         (goto-char here))))
1364 \f
1365 ;;; Start and exit
1366
1367 ;;;###autoload
1368 (defun forms-find-file (fn)
1369   "Visit a file in Forms mode."
1370   (interactive "fForms file: ")
1371   (find-file-read-only fn)
1372   (or forms--mode-setup (forms-mode t)))
1373
1374 ;;;###autoload
1375 (defun forms-find-file-other-window (fn)
1376   "Visit a file in Forms mode in other window."
1377   (interactive "fFbrowse file in other window: ")
1378   (find-file-other-window fn)
1379   (eval-current-buffer)
1380   (or forms--mode-setup (forms-mode t)))
1381
1382 (defun forms-exit (query)
1383   "Normal exit from Forms mode.  Modified buffers are saved."
1384   (interactive "P")
1385   (forms--exit query t))
1386
1387 (defun forms-exit-no-save (query)
1388   "Exit from Forms mode without saving buffers."
1389   (interactive "P")
1390   (forms--exit query nil))
1391 \f
1392 ;;; Navigating commands
1393
1394 (defun forms-next-record (arg)
1395   "Advance to the ARGth following record."
1396   (interactive "P")
1397   (forms-jump-record (+ forms--current-record (prefix-numeric-value arg)) t))
1398
1399 (defun forms-prev-record (arg)
1400   "Advance to the ARGth previous record."
1401   (interactive "P")
1402   (forms-jump-record (- forms--current-record (prefix-numeric-value arg)) t))
1403
1404 (defun forms-jump-record (arg &optional relative)
1405   "Jump to a random record."
1406   (interactive "NRecord number: ")
1407
1408   ;; Verify that the record number is within range.
1409   (if (or (> arg forms--total-records)
1410           (<= arg 0))
1411     (progn
1412       (beep)
1413       ;; Don't give the message if just paging.
1414       (if (not relative)
1415           (message "Record number %d out of range 1..%d"
1416                    arg forms--total-records))
1417       )
1418
1419     ;; Flush.
1420     (forms--checkmod)
1421
1422     ;; Calculate displacement.
1423     (let ((disp (- arg forms--current-record))
1424           (cur forms--current-record))
1425
1426       ;; `forms--show-record' needs it now.
1427       (setq forms--current-record arg)
1428
1429       ;; Get the record and show it.
1430       (forms--show-record
1431        (save-excursion
1432          (set-buffer forms--file-buffer)
1433          (beginning-of-line)
1434
1435          ;; Move, and adjust the amount if needed (shouldn't happen).
1436          (if relative
1437              (if (zerop disp)
1438                  nil
1439                (setq cur (+ cur disp (- (forward-line disp)))))
1440            (setq cur (+ cur disp (- (goto-line arg)))))
1441
1442          (forms--get-record)))
1443
1444       ;; This shouldn't happen.
1445       (if (/= forms--current-record cur)
1446           (progn
1447             (setq forms--current-record cur)
1448             (beep)
1449             (message "Stuck at record %d" cur))))))
1450
1451 (defun forms-first-record ()
1452   "Jump to first record."
1453   (interactive)
1454   (forms-jump-record 1))
1455
1456 (defun forms-last-record ()
1457   "Jump to last record.
1458 As a side effect: re-calculates the number of records in the data file."
1459   (interactive)
1460   (let
1461       ((numrec
1462         (save-excursion
1463           (set-buffer forms--file-buffer)
1464           (count-lines (point-min) (point-max)))))
1465     (if (= numrec forms--total-records)
1466         nil
1467       (beep)
1468       (setq forms--total-records numrec)
1469       (message "Warning: number of records changed to %d" forms--total-records)))
1470   (forms-jump-record forms--total-records))
1471 \f
1472 ;;; Other commands
1473
1474 (defun forms-toggle-read-only (arg)
1475   "Toggles read-only mode of a forms mode buffer.
1476 With an argument, enables read-only mode if the argument is positive.
1477 Otherwise enables edit mode if the visited file is writeable."
1478
1479   (interactive "P")
1480
1481   (if (if arg
1482           ;; Negative arg means switch it off.
1483           (<= (prefix-numeric-value arg) 0)
1484         ;; No arg means toggle.
1485         forms-read-only)
1486
1487       ;; Enable edit mode, if possible.
1488       (let ((ro forms-read-only))
1489         (if (save-excursion
1490               (set-buffer forms--file-buffer)
1491               buffer-read-only)
1492             (progn
1493               (setq forms-read-only t)
1494               (message "No write access to \"%s\"" forms-file)
1495               (beep))
1496           (setq forms-read-only nil))
1497         (if (equal ro forms-read-only)
1498             nil
1499           (forms-mode)))
1500
1501     ;; Enable view mode.
1502     (if forms-read-only
1503         nil
1504       (forms--checkmod)                 ; sync
1505       (setq forms-read-only t)
1506       (forms-mode))))
1507
1508 ;; Sample:
1509 ;; (defun my-new-record-filter (the-fields)
1510 ;;   ;; numbers are relative to 1
1511 ;;   (aset the-fields 4 (current-time-string))
1512 ;;   (aset the-fields 6 (user-login-name))
1513 ;;   the-list)
1514 ;; (setq forms-new-record-filter 'my-new-record-filter)
1515
1516 (defun forms-insert-record (arg)
1517   "Create a new record before the current one.
1518 With ARG: store the record after the current one.
1519 If `forms-new-record-filter' contains the name of a function,
1520 it is called to fill (some of) the fields with default values."
1521
1522   (interactive "P")
1523
1524   (if forms-read-only
1525       (error ""))
1526
1527   (let ((ln (if arg (1+ forms--current-record) forms--current-record))
1528         the-list the-record)
1529
1530     (forms--checkmod)
1531     (if forms-new-record-filter
1532         ;; As a service to the user, we add a zeroth element so she
1533         ;; can use the same indices as in the forms definition.
1534         (let ((the-fields (make-vector (1+ forms-number-of-fields) "")))
1535           (setq the-fields (funcall forms-new-record-filter the-fields))
1536           (setq the-list (cdr (append the-fields nil))))
1537       (setq the-list (make-list forms-number-of-fields "")))
1538
1539     (setq the-record
1540           (mapconcat
1541           'identity
1542           the-list
1543           forms-field-sep))
1544
1545     (save-excursion
1546       (set-buffer forms--file-buffer)
1547       (goto-line ln)
1548       (open-line 1)
1549       (insert the-record)
1550       (beginning-of-line))
1551
1552     (setq forms--current-record ln))
1553
1554   (setq forms--total-records (1+ forms--total-records))
1555   (forms-jump-record forms--current-record))
1556
1557 (defun forms-delete-record (arg)
1558   "Deletes a record.  With a prefix argument: don't ask."
1559   (interactive "P")
1560
1561   (if forms-read-only
1562       (error ""))
1563
1564   (forms--checkmod)
1565   (if (or arg
1566           (y-or-n-p "Really delete this record? "))
1567       (let ((ln forms--current-record))
1568         (save-excursion
1569           (set-buffer forms--file-buffer)
1570           (goto-line ln)
1571           ;; Use delete-region instead of kill-region, to avoid
1572           ;; adding junk to the kill-ring.
1573           (delete-region (save-excursion (beginning-of-line) (point))
1574                          (save-excursion (end-of-line) (1+ (point)))))
1575         (setq forms--total-records (1- forms--total-records))
1576         (if (> forms--current-record forms--total-records)
1577             (setq forms--current-record forms--total-records))
1578         (forms-jump-record forms--current-record)))
1579   (message ""))
1580
1581 (defun forms-search (regexp)
1582   "Search REGEXP in file buffer."
1583   (interactive
1584    (list (read-string (concat "Search for"
1585                                   (if forms--search-regexp
1586                                    (concat " ("
1587                                            forms--search-regexp
1588                                            ")"))
1589                                   ": "))))
1590   (if (equal "" regexp)
1591       (setq regexp forms--search-regexp))
1592   (forms--checkmod)
1593
1594   (let (the-line the-record here
1595                  (fld-sep forms-field-sep))
1596     (if (save-excursion
1597           (set-buffer forms--file-buffer)
1598           (setq here (point))
1599           (end-of-line)
1600           (if (null (re-search-forward regexp nil t))
1601               (progn
1602                 (goto-char here)
1603                 (message (concat "\"" regexp "\" not found."))
1604                 nil)
1605             (setq the-record (forms--get-record))
1606             (setq the-line (1+ (count-lines (point-min) (point))))))
1607         (progn
1608           (setq forms--current-record the-line)
1609           (forms--show-record the-record)
1610           (re-search-forward regexp nil t))))
1611   (setq forms--search-regexp regexp))
1612
1613 (defun forms-revert-buffer (&optional arg noconfirm)
1614   "Reverts current form to un-modified."
1615   (interactive "P")
1616   (if (or noconfirm
1617           (yes-or-no-p "Revert form to unmodified? "))
1618       (progn
1619         (set-buffer-modified-p nil)
1620         (forms-jump-record forms--current-record))))
1621
1622 (defun forms-next-field (arg)
1623   "Jump to ARG-th next field."
1624   (interactive "p")
1625
1626   (let ((i 0)
1627         (here (point))
1628         there
1629         (cnt 0))
1630
1631     (if (zerop arg)
1632         (setq cnt 1)
1633       (setq cnt (+ cnt arg)))
1634
1635     (if (catch 'done
1636           (while (< i (length forms--markers))
1637             (if (or (null (setq there (aref forms--markers i)))
1638                     (<= there here))
1639                 nil
1640               (if (<= (setq cnt (1- cnt)) 0)
1641                   (progn
1642                     (goto-char there)
1643                     (throw 'done t))))
1644             (setq i (1+ i))))
1645         nil
1646       (goto-char (aref forms--markers 0)))))
1647
1648 (defun forms-prev-field (arg)
1649   "Jump to ARG-th previous field."
1650   (interactive "p")
1651
1652   (let ((i (length forms--markers))
1653         (here (point))
1654         there
1655         (cnt 0))
1656
1657     (if (zerop arg)
1658         (setq cnt 1)
1659       (setq cnt (+ cnt arg)))
1660
1661     (if (catch 'done
1662           (while (> i 0)
1663             (setq i ( 1- i))
1664             (if (or (null (setq there (aref forms--markers i)))
1665                     (>= there here))
1666                 nil
1667               (if (<= (setq cnt (1- cnt)) 0)
1668                   (progn
1669                     (goto-char there)
1670                     (throw 'done t))))))
1671         nil
1672       (goto-char (aref forms--markers (1- (length forms--markers)))))))
1673 ;;;
1674 ;;; Special service
1675 ;;;
1676 (defun forms-enumerate (the-fields)
1677   "Take a quoted list of symbols, and set their values to sequential numbers.
1678 The first symbol gets number 1, the second 2 and so on.
1679 It returns the higest number.
1680
1681 Usage: (setq forms-number-of-fields
1682              (forms-enumerate
1683               '(field1 field2 field2 ...)))"
1684
1685   (let ((the-index 0))
1686     (while the-fields
1687       (setq the-index (1+ the-index))
1688       (let ((el (car-safe the-fields)))
1689         (setq the-fields (cdr-safe the-fields))
1690         (set el the-index)))
1691     the-index))
1692 \f
1693 ;;; Debugging
1694
1695 (defvar forms--debug nil
1696   "*Enables forms-mode debugging if not nil.")
1697
1698 (defun forms--debug (&rest args)
1699   "Internal debugging routine."
1700   (if forms--debug
1701       (let ((ret nil))
1702         (while args
1703           (let ((el (car-safe args)))
1704             (setq args (cdr-safe args))
1705             (if (stringp el)
1706                 (setq ret (concat ret el))
1707               (setq ret (concat ret (prin1-to-string el) " = "))
1708               (if (boundp el)
1709                   (let ((vel (eval el)))
1710                     (setq ret (concat ret (prin1-to-string vel) "\n")))
1711                 (setq ret (concat ret "<unbound>" "\n")))
1712               (if (fboundp el)
1713                   (setq ret (concat ret (prin1-to-string (symbol-function el))
1714                                     "\n"))))))
1715         (save-excursion
1716           (set-buffer (get-buffer-create "*forms-mode debug*"))
1717           (if (zerop (buffer-size))
1718               (emacs-lisp-mode))
1719           (goto-char (point-max))
1720           (insert ret)))))
1721
1722 ;;; forms.el ends here.
1723