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