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