home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / edb / db-format.el < prev    next >
Encoding:
Text File  |  1993-06-14  |  92.7 KB  |  2,509 lines
  1. ;;; db-format.el --- part of EDB, the Emacs database
  2.  
  3. ;; See database.el for copyright notice, distribution conditions, etc.
  4.  
  5. ;; Author: Michael Ernst <mernst@theory.lcs.mit.edu>
  6. ;; Keywords: EDB
  7.  
  8. ;;; Commentary:
  9.  
  10. ;; Displaying and editing database records.
  11.  
  12. ;;; Code:
  13.  
  14.  
  15. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  16. ;;; Variables
  17. ;;;
  18.  
  19. ;;;
  20. ;;; The format
  21. ;;;
  22.  
  23. (deflocalvar dbf-always-forms nil
  24.   "Forms executed every time that the format is selected.
  25. These forms are only executed when a different format is replaced, not
  26. every time that a record is displayed (or even every time that
  27. `db-alternate-format' is called).  See also
  28. `dbf-before-display-record-function'.")
  29.  
  30. (deflocalvar dbf-displayspecs nil
  31.   "An array of field specifiers, one for each field of the display format.
  32. There are `dbf-displayspecs-length' of them.")
  33.  
  34. (deflocalvar dbf-displayspecs-length nil
  35.   "The number of displayspecs in the current format.")
  36.  
  37. (deflocalvar dbf-inter-field-text nil
  38.   "A vector with one string, the constant text that precedes that field in
  39. the display, per displayspec, plus a final slot for trailing text.")
  40.  
  41. (defvar db-fontification db-running-lucid-emacs
  42.   "Non-nil if uneditable text in data display buffers should use a special font.
  43. Don't set this unless you are running Lucid GNU Emacs!")
  44.  
  45. (deflocalvar dbf-recordindex-displayspecno-vector nil)
  46.  
  47. (defun dbf-fieldname->displayspecno (fieldname)
  48.   (aref dbf-recordindex-displayspecno-vector
  49.     (fieldname->fieldnumber fieldname dbc-database)))
  50.  
  51. ;; Should this be buffer-local?  Yes, since it's specific to a format, not
  52. ;; a database.
  53. ;; This isn't getting set anywhere.
  54. (deflocalvar dbf-fieldabbrevs nil
  55.   "Database-format-specific alist of fieldabbrevs and displayspecs.")
  56.  
  57. ;;;
  58. ;;; Location in the format (field info)
  59. ;;;
  60.  
  61. (deflocalvar dbf-this-displayspec nil
  62.   "The displayspec currently being operated upon, or nil.")
  63.  
  64. (deflocalvar dbf-this-field-index nil
  65.   "The index in `dbf-displayspecs' of the current displayspec, or nil.")
  66.  
  67. ;; This is primarily used by the change-functions, which may not even be
  68. ;; interested in the information.  Perhaps give them the field number
  69. ;; instead and have them compute the info if they care.
  70. ;; It is also called for messages to the user.
  71. (defun dbf-this-field-name ()
  72.   (and dbf-this-displayspec
  73.        (fieldnumber->fieldname (displayspec-record-index dbf-this-displayspec)
  74.                    dbc-database)))
  75.  
  76. ;; A region-modification-hook could get rid of the need for the functions
  77. ;; and turn this back into an ordinary variable; but this is kind of a nice
  78. ;; solution, I think.
  79. ;; (deflocalvar dbf-this-field-modified-p-internal nil
  80. ;;   "T if the current field has been modified, nil otherwise.
  81. ;; Don't use this directly; use the functions
  82. ;; dbf-this-field-modified-p and dbf-set-this-field-modified-p.")
  83. (defun dbf-this-field-modified-p ()
  84.   (buffer-modified-p))
  85. (proclaim-inline dbf-this-field-modified-p)
  86. (defun dbf-set-this-field-modified-p (arg)
  87.   (set-buffer-modified-p arg))
  88. (proclaim-inline dbf-set-this-field-modified-p)
  89.  
  90. ;; This is not currently used anywhere.
  91. (deflocalvar dbf-wraparound-p 't
  92.   "Value t, nil, or 'delay determines whether going forward from the last
  93. field (or backward from the first) wraps, is prohibited, or delays.
  94. 'delay has the effect of prohibiting such movement the first time, but if
  95. the user immediately makes a second attempt, that one is successful.
  96. Somewhat analogous to dbc-wraparound-p.")
  97.  
  98. (deflocalvar dbf-this-field-beginning-pos nil
  99.   "A position, the beginning of the current field.")
  100.  
  101. ;; Maybe this should be next-field-beginning-mark.  No, because there might
  102. ;; not be any space between the end of this field and the beginning of the
  103. ;; next one, which is bad for the same reason putting the mark righat at
  104. ;; the end of this field is:  in the event of deleting the entire field,
  105. ;; the mark get put at the beginning of the field; but ordinarily
  106. ;; characters are inserted after marks, which would leave the mark at the
  107. ;; beginning instead of the end of the field.
  108. (deflocalvar dbf-this-field-end-marker (make-marker)
  109.   "A mark one character past the end of the current field, or nil if current
  110. field extends to end of buffer.")
  111.  
  112. ;; Only need one of these ever.
  113. ;;   "Remember where the user just moved while possibly munging a field."
  114. (defvar dbf-moving-mark (make-marker))
  115.  
  116.  
  117. ;;;
  118. ;;; The displayed record
  119. ;;;
  120.  
  121. ;; Could add another variable to determine which record is being used,
  122. ;; since we might cause a record to be put into the database and then
  123. ;; immediately begin editing it again; but it's not all that expensive to
  124. ;; copy the slots, and that situation should be rare anyway; we don't need
  125. ;; any more variables, after all.
  126.  
  127. ;; Do not confuse with the record in the current link.  Real live database
  128. ;; records are never directly operated upon; we always munge the copy so
  129. ;; that the original can be restored if desired.
  130. (deflocalvar dbf-this-record nil
  131.   "The record currently displayed and edited.  This is an honest-to-goodness
  132. record whose slots are filled from `dbf-this-record-original' if it's modified.
  133. The variable's value should never be set except by `copy-record-to-record'; its
  134. slots may be freely modified, however.
  135. This is only used if `dbf-this-record-modified-p' is t.")
  136.  
  137. (deflocalvar dbf-this-record-original nil
  138.   "The original of  dbf-this-record; a pointer to some poor unsuspecting
  139. record that shouldn't be modified until everything has been checked out.
  140. That is, when the user is setting fields, this record remains unchanged
  141. and  dbf-this-record, a copy of the original, is munged instead.")
  142.  
  143. (deflocalvar dbf-this-record-modified-p nil
  144.   "T if the current record has been modified, nil otherwise.
  145. This determines which record is returned by `dbf-displayed-record':
  146. if non-nil, then `dbf-this-record-original' has been copied to `dbf-this-record'.
  147. It's best to use `dbf-set-this-record-modified-p' to set this variable.")
  148.  
  149. (deflocalvar dbf-set-this-record-modified-function nil
  150.   "A function called every time the working copy `dbf-this-record' is created
  151. by `dbf-set-this-record-modified-p'.  The function takes no arguments and
  152. its return value is ignored.  It is called after `dbf-this-record-original'
  153. is copied to `dbf-this-record' and after `dbf-this-record-modified-p' is set
  154. to t.")
  155.  
  156. (defun dbf-set-this-record-modified-p (arg)
  157.   "Set the value of `dbf-this-record-modified-p' to ARG.
  158. If ARG is non-nil and `dbf-this-record-modified-p' is nil, also do the
  159. necessary record-copying and call `dbf-set-this-record-modified-function'."
  160.   (cond
  161.    ((and arg (not dbf-this-record-modified-p))
  162.     (setq dbf-this-record-modified-p arg)
  163.     (copy-record-to-record dbf-this-record-original dbf-this-record)
  164.     (maybe-funcall dbf-set-this-record-modified-function))
  165.    (t
  166.     (setq dbf-this-record-modified-p arg))))
  167. (proclaim-inline dbf-set-this-record-modified-p)
  168.  
  169. (defmacro dbf-displayed-record ()
  170.   "Return the record currently displayed in this data display buffer.
  171. This is `dbf-this-record' if `dbf-this-record-modified-p' is non-nil and
  172. `dbf-this-record-original' otherwise."
  173.   '(if dbf-this-record-modified-p
  174.        dbf-this-record
  175.      dbf-this-record-original))
  176.  
  177. ;; Maybe this should be in the fieldspec.  But I don't think so; it should
  178. ;; tell how to format, not remember what was formatted.
  179. (deflocalvar dbf-fields-displayed nil
  180.   "A vector of one string, the displayed text for that field, per displayspec.")
  181.  
  182. (deflocalvar dbf-redisplay-entire-record-p nil
  183.   "T if the whole record needs to be redisplayed.
  184. This is often set by change functions.")
  185.  
  186.  
  187. ;;;
  188. ;;; Hooks
  189. ;;;
  190.  
  191. ;;; Minor mode hooks
  192.  
  193. (defvar db-view-mode-hooks nil
  194.   "Function or list of functions called when database view mode is entered.")
  195.  
  196. (defvar db-edit-mode-hooks nil
  197.   "Function or list of functions called when database edit mode is entered.")
  198.  
  199.  
  200. ;; Should these belong to the format or to the database proper?
  201. ;; Probably to the format (????), I guess.
  202.  
  203. ;;; Movement hooks
  204.  
  205. (deflocalvar dbf-before-display-record-function nil
  206.   "A function called before a record is displayed by `display-record'.
  207. The function should take one argument, the record.
  208.  
  209. This is a good place to put calls to `db-alternate-format'.  Depending on
  210. your function's implementation, however, you may silently override any user
  211. calls to that function.")
  212.  
  213. (deflocalvar dbf-enter-field-function nil
  214.   "A function called whenever a display field is entered.
  215. The function takes the displayspec index as an argument, which is
  216. guaranteed to be `dbf-this-field-index'.")
  217. ;; This function is only be called when the field is entered for real, not just
  218. ;; on the way to the actual destination field.
  219.  
  220. ;;; Change hooks
  221.  
  222. (deflocalvar dbf-first-change-function nil
  223.   "A function called the first time a record field is modified, or nil.
  224. The function takes the fieldname and the old and new values as arguments,
  225. and returns t if the record should be redisplayed.")
  226.  
  227. (deflocalvar dbf-every-change-function nil
  228.   "A function called whenever a record field is modified, or nil.
  229. The function takes the fieldname and the old and new values as arguments,
  230. and returns t if the record should be redisplayed.")
  231.  
  232. (deflocalvar dbf-change-functions nil
  233.   "A vector of one function (or nil) per record field (not display field).
  234. The functions take the fieldname and the old and new values as arguments,
  235. and return t if the record should be redisplayed.
  236. Use `dbf-set-change-function' to set the fields of this vector.")
  237.  
  238. (defun dbf-set-change-function (fieldname function)
  239.   "Set the change function for FIELDNAME to FUNCTION in the current database.
  240. FUNCTION should take the fieldname and the old and new values as arguments,
  241. and return t if the record should be redisplayed."
  242.   (aset dbf-change-functions
  243.     (fieldname->fieldnumber fieldname dbc-database)
  244.     function))
  245.  
  246. (deflocalvar dbf-after-record-change-function nil
  247.   "Function called whenever changes to a record are recorded semi-permanently
  248. by `dbf-process-current-record-maybe'.  For convenience, the function
  249. takes the record as an argument, which is guaranteed to be `dbf-this-record'.
  250. Its return value is ignored.")
  251.  
  252.  
  253. ;; Should this be reset-on-display-list?  Well, I have a hook there, so
  254. ;; programmers can get the same effect by putting the code there by hand.
  255. ;; Of course, the question is whether we want something so specific at all;
  256. ;; perhaps the display-hook really is the right place to put all this.
  257. (deflocalvar dbf-reset-on-edit-list nil
  258.   "An alist of (variable-name . default-value) pairs.
  259. Every time Edit Mode is entered, these buffer-local variables are reset to
  260. their default values.  This is good for making sure that something only
  261. happens once each time a record is edited.")
  262.  
  263.  
  264. ;;;
  265. ;;; The minor mode
  266. ;;;
  267.  
  268. (deflocalvar dbf-minor-mode nil
  269.   "A symbol, either 'view or 'edit.")
  270.  
  271. (deflocalvar dbf-minor-mode-name nil
  272.   "\"View\" or \"Edit\".")
  273.  
  274. ;;;
  275. ;;; Alternate formats
  276. ;;;
  277.  
  278. ;; Some variables local to the data display buffer don't need to be changed
  279. ;; when the display format changes.  The ones manipulated below do.
  280.  
  281. (deflocalvar dbf-format-name nil
  282.   "The string representing the format currently in use.")
  283.  
  284. (deflocalvar dbf-format-file nil
  285.   "The format file from which this format was built.")
  286.  
  287. (deflocalvar dbf-alternate-format-names nil
  288.   "Association list of format names and format specifiers.
  289. Each format name is an arbitrary string.
  290. A format specifier is a filename or a list of values for format variables.
  291. The user sets the format specifier to a filename, and after that format file
  292. has been read, EDB replaces the filename with a list of values for format
  293. variables, so that the file need not be read again.
  294.  
  295. It is convenient for a database designer to set this, pre-assigning format
  296. names to files so that the user only needs to remember the format names,
  297. not the filenames.")
  298.  
  299. (deflocalvar dbf-alternate-format-files nil
  300.   "Association list of file names and format file specifiers.
  301. A format file specifier is a list of values for format variables.
  302. The user should not set this variable; use `dbf-alternate-format-names' instead.")
  303.  
  304. ;; I should perhaps split this up.
  305. (defun dbf-make-format-spec ()
  306.   ;; All of these items vary from format to format within a particular
  307.   ;; data display buffer; that is why I save them away, so that they can be
  308.   ;; restored when the user returns to a format which was used previously in
  309.   ;; this data display buffer.
  310.   (list
  311.    dbf-format-file
  312.    ;; These can vary between data display buffers which happen to be using
  313.    ;; the same format file to specify the layout of the record's fields.
  314.    ;; That is, these are specific to a particular data display buffer, not
  315.    ;; to a format, because they have to do with what is actually being
  316.    ;; displayed and/or because we might expect the user to change them
  317.    ;; after reading in the format.  This is why we can't just associate
  318.    ;; this information with the format file, but have to save it on a
  319.    ;; per-data-display-buffer basis.  If this function only stored away the
  320.    ;; name of the format file and dbf-install-format-spec inferred the
  321.    ;; values of the following variables, I wouldn't get what I want.
  322.    dbf-summary-format
  323.    dbf-summary-function
  324.    dbf-fields-displayed
  325.    dbf-field-search-defaults))
  326.  
  327. (defun dbf-install-format-spec (format-spec)
  328.   (setq dbf-format-file (car format-spec))
  329.   (setq format-spec (cdr format-spec))
  330.   (setq dbf-summary-format (car format-spec))
  331.   (setq format-spec (cdr format-spec))
  332.   (setq dbf-summary-function (car format-spec))
  333.   (setq format-spec (cdr format-spec))
  334.   (setq dbf-fields-displayed (car format-spec))
  335.   (setq format-spec (cdr format-spec))
  336.   (setq dbf-field-search-defaults (car format-spec))
  337.   (setq format-spec (cdr format-spec)))
  338.  
  339. (defun format-spec-format-file (format-spec)
  340.   (if (listp format-spec)
  341.       (car format-spec)
  342.     format-spec))
  343.  
  344. (defun dbf-make-format-file-spec ()
  345.   ;; These are constant for a particular format file.
  346.   (list
  347.    dbf-always-forms
  348.    dbf-displayspecs
  349.    dbf-displayspecs-length
  350.    dbf-inter-field-text
  351.    dbf-recordindex-displayspecno-vector))
  352.  
  353. (defun dbf-install-format-file-spec (format-file-spec)
  354.   (setq dbf-always-forms (car format-file-spec))
  355.   (mapcar (function eval) dbf-always-forms)
  356.   (setq dbf-displayspecs (car (cdr format-file-spec))
  357.     dbf-displayspecs-length (car (cdr (cdr format-file-spec)))
  358.     dbf-inter-field-text (nth 3 format-file-spec)
  359.     dbf-recordindex-displayspecno-vector (nth 4 format-file-spec)))
  360.  
  361.  
  362. ;;;
  363. ;;; Etc.
  364. ;;;
  365.  
  366. ;; Anything in the "Etc." section probably doesn't belong here.
  367.  
  368.  
  369.  
  370. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  371. ;;; Constants
  372. ;;;
  373.  
  374. ;;   "Regular expression which matches any number of pairs of backslashes.
  375. ;; Usually used in conjunction with other regexps.")
  376. (defconst doubled-backslash-regexp "\\(\\\\\\\\\\)*")
  377.  
  378. (defconst non-backslash-character-regexp "\\(^\\|[^\\]\\)")
  379.  
  380. ;; For finding displayspecs, use these regexps:
  381.  
  382. (defconst symbol-or-number-regexp "[-<>a-zA-Z0-9]+")
  383. (defconst symbol-regexp "[a-zA-Z][-<>a-zA-Z0-9]*")
  384. (defconst fieldname-regexp (concat "\\\\" symbol-regexp))
  385. ;; last item is brackets-surrounded material, for one-char alternative types
  386. (defconst displaytype-nonsymbol-regexp "#\\|\\$\\|\"\\|'\\|\\[[^]]+\\]")
  387. ;; Does NOT include leading backslashes or commas.
  388.  
  389. ;; Perhaps the comma shouldn't be optional; but then I'd have to do special
  390. ;; work for the first field, which I'm loathe to do.
  391. (defconst displaytype-regexp (concat ",?"
  392.                    "\\(" symbol-regexp
  393.                    "\\|" displaytype-nonsymbol-regexp
  394.                    "\\)"))
  395.  
  396. (defconst fieldoption-regexp (concat displaytype-regexp
  397.                      "\\(=\\(" symbol-or-number-regexp "\\)\\)?"))
  398. (defconst fieldoption-regexp-symbol 1)
  399. (defconst fieldoption-regexp-equals 3)
  400. (defconst fieldoptions-regexp (concat "\\(" fieldoption-regexp "\\)*"))
  401.  
  402. ;; (defconst displayspec-regexp-no-context (concat "\\(" fieldname-regexp "\\)"
  403. ;;                         fieldoptions-regexp))
  404. ;; (defconst displayspec-regexp (concat doubled-backslash-regexp
  405. ;;                      non-backslash-character-regexp
  406. ;;                      "\\(" fieldname-regexp "\\)"
  407. ;;                      fieldoptions-regexp
  408. ;;                      ;; possibly "\ " at the end
  409. ;;                      "\\(\\\\ \\)?"))
  410. (defconst displayspec-regexp (concat "\\(" fieldname-regexp "\\)"
  411.                      fieldoptions-regexp
  412.                      ;; possibly "\ " at the end
  413.                      "\\(\\\\ \\)?"))
  414. (defconst displayspec-regexp-fieldname 1)
  415. (defconst displayspec-regexp-fieldoptions 2)
  416. (defconst displayspec-regexp-content-beginning displayspec-regexp-fieldname)
  417. (defconst displayspec-regexp-content-end 0)
  418. ;; If there was no match for the fieldoptions
  419. (defconst displayspec-regexp-content-end-alt displayspec-regexp-fieldname)
  420.  
  421.  
  422. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  423. ;;; Abstraction
  424. ;;;
  425.  
  426. ;; The displayspec contains record-index (indicates from which slot of the
  427. ;; database record this data comes); all other information has to do with
  428. ;; display only.  The fields are documented in the texinfo file.
  429.  
  430. ;; ** Change optspec-list if this structure is changed! **
  431. (def-db-struct (displayspec (:constructor old-make-displayspec))
  432.   record-index
  433.  
  434.   ;; size and shape
  435.   indent
  436.   min-width
  437.   max-width
  438.   min-height                ; default 1
  439.   max-height                ; default 1
  440.   min-bytes
  441.   max-bytes
  442.  
  443.   ;; other display info
  444.   truncation-display-action
  445.   padding-action
  446.   actual->display
  447.   display->actual
  448.   ;; Is this where these belong?  Well, it lets me not make a new displayspec
  449.   ;; for them...
  450.   match-actual->display
  451.   match-display->actual
  452.  
  453.   ;; editing info
  454.   truncation-editing-action
  455.   reachablep
  456.   )
  457.  
  458. (defun make-displayspec ()
  459.   "Create and return a new displayspec."
  460.   (let ((ds (old-make-displayspec)))
  461.     (displayspec-set-min-height ds 1)
  462.     (displayspec-set-max-height ds 1)
  463.     (displayspec-set-reachablep ds t)
  464.     ds))
  465.  
  466. ;; This is a hack, because it's hard-coded.  It used to use
  467. ;; slotname->index, but there isn't a simple one for the defstruct I'm
  468. ;; currently using.  Changes in the definition of defstruct or of the
  469. ;; displayspec structure will cause this to be in error.
  470.  
  471. ;; The functions are not symbol-function'ed because that makes debugging a
  472. ;; nightmare for a small performance increase.
  473.  
  474. ;; List of optspecinfos, which tell how to interpret optional parameters to a
  475. ;; display field specification.  An optspecinfo is a list of a string (the
  476. ;; optional parameter name), an accessor, and a function which will be called
  477. ;; on the value part of the optional parameter (that is, what follows the
  478. ;; equal sign) to produce the actual value.  The accessor is a slotnumber in
  479. ;; the displayspec structure, a list of slotnumbers, or a function taking a
  480. ;; displayspec and a value and doing whatever is appropriate.
  481. (defconst optspec-list
  482.   (list
  483.    (list "indent" 2 '(lambda (x) t))
  484.    (list "noindent" 2 '(lambda (x) nil))
  485.   
  486.    (list "width" '(3 4) 'string->number)
  487.    (list "min-width" 3 'string->number)
  488.    (list "max-width" 4 'string->number)
  489.    (list "length" '(3 4) 'string->number)
  490.    (list "min-length" 3 'string->number)
  491.    (list "max-length" 4 'string->number)
  492.    (list "height" '(5 6) 'string->number)
  493.    (list "min-height" 5 'string->number)
  494.    (list "max-height" 6 'string->number)
  495.    (list "bytes" '(7 8) 'string->number)
  496.    (list "min-bytes" 7 'string->number)
  497.    (list "max-bytes" 8 'string->number)
  498.   
  499.    (list "trunc-display" 9 'intern)
  500.    (list "truncation-display-action" 9 'intern)
  501.    (list "padding-action" 10 'intern)
  502.    (list "right-justify" 10 'right-justify-slotsetter-function)
  503.    (list "actual->display" 11 'intern)
  504.    (list "a->d" 11 'intern)
  505.    (list "display->actual" 12 'intern)
  506.    (list "d->a" 12 'intern)
  507.   
  508.    ;; match-actual->display and match-display->actual, fields 13 and 14
  509.   
  510.    (list "truncation-editing-action" 15 'intern)
  511.    (list "trunc-edit" 15 'intern)
  512.    (list "reachable" 16 '(lambda (x) t))
  513.    (list "unreachable" 16 '(lambda (x) nil))
  514.    ))
  515.  
  516. (defun right-justify-slotsetter-function (&rest args)
  517.   ;;
  518.   (cons ?  t))
  519.  
  520. ;; These are funcalled [in code that I've given up on]; they can't be macros.
  521.  
  522. (defun optspecinfo-accessor (optspec-info)
  523.   (car (cdr optspec-info)))
  524. (proclaim-inline optspecinfo-accessor)
  525.  
  526. (defun optspecinfo-specfunction (optspec-info)
  527.   (car (cdr (cdr optspec-info))))
  528. (proclaim-inline optspecinfo-specfunction)
  529.  
  530. (defmacro display->actual-call (d->a fieldtext prev-value record recordfieldno)
  531.   (` (let ((dac-d->a (, d->a))
  532.        (dac-fieldtext (, fieldtext)))
  533.        (if dac-d->a
  534.        (vararg-call funcall 2 5
  535.             dac-d->a dac-fieldtext
  536.             (, prev-value) (, record) (, recordfieldno))
  537.      dac-fieldtext))))
  538.  
  539. (defmacro actual->display-call (a->d fieldtext record recordfieldno)
  540.   (` (let* ((adc-a->d (, a->d))
  541.         (adc-fieldtext (, fieldtext))
  542.         (adc-result (if adc-a->d
  543.                 (vararg-call funcall 2 4
  544.                      adc-a->d adc-fieldtext
  545.                      (, record) (, recordfieldno))
  546.               adc-fieldtext)))
  547.        (if (stringp adc-result)
  548.        adc-result
  549.      "<ERROR>"))))
  550.  
  551. ;; (macroexpand '(display->actual-call foo bar baz bum quux))
  552. ;; (macroexpand '(actual->display-call foo bar baz bum))
  553.  
  554.  
  555. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  556. ;;; Macros
  557. ;;;
  558.  
  559. ;; The data display buffer should never be narrowed.
  560. ;; This is a macro so that, if the above assertion becomes no longer true,
  561. ;; I can easily rectify the situation.
  562. (defmacro dbf-point-min ()
  563.   1)
  564.  
  565.  
  566. ;; The text actually in the buffer.
  567. (defun dbf-this-field-text ()
  568.  (buffer-substring dbf-this-field-beginning-pos (dbf-this-field-end-pos)))
  569. (proclaim-inline dbf-this-field-text)
  570.  
  571. ;; Sets the text actually in the buffer.
  572. (defun dbf-set-this-field-text (field-text)
  573.   "Make the format display FIELD-TEXT in the current field."
  574.  
  575.   ;; Maybe eventually I'll have to reverse the order of deletion and
  576.   ;; insertion so as not to get on the wrong side of a marker.
  577.  
  578.   ;; delete old value
  579.   (delete-region dbf-this-field-beginning-pos (dbf-this-field-end-pos))
  580.   ;; insert new value
  581.   (goto-char dbf-this-field-beginning-pos)
  582.   (insert field-text)
  583.  
  584.   )
  585.  
  586. ;; If the user has deleted some of the leading spaces, they'll be restored.
  587. ;; Don't do anything about tabs, not even untabifying.
  588.  
  589. ;; The text actually in the buffer, adjusted for rectangularp.
  590. (defun dbf-this-field-text-unrect ()
  591.   (let ((text (dbf-this-field-text)))
  592.     (db-debug-message "dbf-this-field-text-unrect: indent = %s"
  593.               (displayspec-indent dbf-this-displayspec))
  594.     (unindentify text)))
  595.  
  596. ;; Uses dbf-this-displayspec.
  597. (defun indentify-absolute (text)
  598.   (let ((amt (dbf-this-field-indent)))
  599.     (if amt
  600.     (string-substitute-substring-general-case
  601.      (concat "\n" (make-string amt ? )) "\n" text)
  602.       text)))
  603. (defun unindentify (text)
  604.   (let ((amt (dbf-this-field-indent)))
  605.     (if amt
  606.     (string-substitute-substring-general-case
  607.      "\n" (concat "\n" (space-maybe-regexp amt)) text)
  608.       text)))
  609.  
  610. ;;   "Return a regexp matching N or fewer occurrences of the space character.
  611. ;; If N is nil, return the empty string, which is sometimes not a regexp you
  612. ;; want to search for by itself."
  613. (defun space-maybe-regexp (n)
  614.   (if n
  615.       (let ((result (make-string (* 2 n) ? )))
  616.     (setq n (1- (* 2 n)))
  617.     (while (> n 0)
  618.       (aset result n ??)
  619.       (setq n (- n 2)))
  620.     result)
  621.     ""))
  622.  
  623. ;; Problem:  for the current field, "displayed" may not correspond to
  624. ;; what's actually shown, producing problems in moving around.  I want to
  625. ;; be able to skip over that, or to be careful to go around it.
  626.  
  627. ;; I don't want to just remember the needed changes and make them later,
  628. ;; since the user may be asked questions, etc.
  629.  
  630. ;; Maybe using db-emergency-restore-format is better; it needn't do all this searching, for instance.
  631.  
  632.  
  633. ;; Avoid any processing, etc; just go to the field, do the work, come back.
  634. (defun dbf-set-field-text (fieldno field-text)
  635.  
  636.   (error "dbf-set-field-text not yet implemented.")
  637.   ;; ...
  638.  
  639.   )
  640.  
  641. ;; Avoid any processing, etc; just go to the field setting the few
  642. ;; variables that must be set.
  643. (defun dbf-goto-field (fieldno)
  644.  
  645.   (error "dbf-goto-field not yet implemented.")
  646.   ;; ...
  647.  
  648.   )
  649.  
  650.  
  651. ;;; This is never used.
  652. ;; ;; Sets the text actually in the buffer, adjusted for rectangularp.
  653. ;; (defun dbf-set-this-field-text-unrect (field-text)
  654. ;;   (dbf-set-this-field-text)
  655. ;;   (if (displayspec-rectangularp dbf-this-displayspec)
  656. ;;       (save-restriction
  657. ;;     (narrow-to-region (point) dbf-this-field-beginning-pos)
  658. ;;     (goto-char dbf-this-field-beginning-pos)
  659. ;;     (replace-string "\n" (concat "\n" (make-string (current-column) 32))))))
  660.  
  661.  
  662. ;; Maybe get rid of "this" from the name.
  663. (defmacro dbf-set-this-field-index (new-index)
  664.   (` (let* ((i (, new-index))
  665.         (index (and i (% i dbf-displayspecs-length))))
  666.        (setq dbf-this-field-index index
  667.          dbf-this-displayspec (and index
  668.                        (aref dbf-displayspecs index))))))
  669.  
  670.  
  671.  
  672. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  673. ;;; Mode selection
  674. ;;;
  675.  
  676. ;; Question:  should view-mode be doing this work?  Given that the user can
  677. ;; call it directly, probably.  Should there be an -internal version?
  678. ;; Probably.
  679.  
  680. ;; Note that this does NOT call dbf-process-current-record-maybe.  Should
  681. ;; it?  There are arguments both ways.
  682.  
  683. (defun db-view-mode (&optional arg)
  684.   "Switch to database view mode.
  685. With an argument, toggle between view and edit modes."
  686.   (interactive "P")
  687.  
  688.   (cond ((not (db-data-display-buffer-p))
  689.      (error "Only call this in database mode."))
  690.     ((and arg (eq dbf-minor-mode 'view))
  691.      (db-edit-mode))
  692.     ;; If already in view mode, don't do anything.
  693.     ((not (eq dbf-minor-mode 'view))
  694.      (dbf-process-field-maybe t)
  695.      (setq dbf-minor-mode 'view
  696.            dbf-minor-mode-name "View")
  697.      (use-local-map database-view-mode-map)
  698.      (setq dbf-this-field-index nil
  699.            dbf-this-displayspec nil)
  700.      (setq buffer-read-only t)
  701.      (goto-char (dbf-point-min))
  702.      (dbf-set-this-field-modified-p nil)
  703.      (if db-running-lucid-emacs
  704.          (db-lucid-view-mode-menubar))
  705.      (run-hooks 'db-view-mode-hooks))))
  706.  
  707. (defun db-edit-mode (&optional arg)
  708.   "Switch to Database Edit mode.
  709. With an argument, toggle between Edit and View modes."
  710.  
  711.   ;; This isn't interactive because it doesn't move point anywhere reasonable.
  712.   ;;  (interactive "P")
  713.  
  714.   (cond ((not (db-data-display-buffer-p))
  715.      (error "Only call this in database mode."))
  716.     ((and arg (eq dbf-minor-mode 'edit))
  717.      (db-view-mode))
  718.     (t
  719.      (setq dbf-minor-mode 'edit
  720.            dbf-minor-mode-name "Edit")
  721.      (use-local-map database-edit-mode-map)
  722.      (if (database-modifiable-p dbc-database)
  723.          (setq buffer-read-only nil)
  724.        (message "Database is not modifiable; use db-toggle-modifiable-p to change that."))
  725.      (mapcar (function (lambda (varname-value)
  726.                  (make-variable-buffer-local (car varname-value))
  727.                  (set (car varname-value) (cdr varname-value))))
  728.          dbf-reset-on-edit-list)
  729.      (force-mode-line-update)
  730.      (if db-running-lucid-emacs
  731.          (db-lucid-edit-mode-menubar))
  732.      (run-hooks 'db-edit-mode-hooks))))
  733.  
  734.  
  735. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  736. ;;; Movement in the format
  737. ;;;
  738.  
  739. ;; This could ask a y-or-n-p question about calling emergency-restore, but
  740. ;; the user will probably always answer yes anyway.
  741.  
  742. (defun db-parse-buffer-error (format-string &rest args)
  743.   (if db-debug-p
  744.       (apply (function error) format-string args)
  745.     (progn
  746.       (db-emergency-restore-format)
  747.       (db-message "I was confused about where I was.  Changes to the field might have been lost."))))
  748.  
  749. ;; The obvious implementation doesn't work because after moving to the
  750. ;; correct row and column and doing db-jump-to-point, we might end up on
  751. ;; another row.  And we wouldn't know whether we belong there (because it's
  752. ;; the next occupied line) or we've overshot (because there was a field in
  753. ;; front of point on the line we originally tried).  The latter case is
  754. ;; unusual but possible nonetheless.
  755. (defun db-next-line-or-field (arg)
  756.   "Move to ARGth next line.  If that would move out of the current field,
  757. move to the closest field to that, but not the current one, wrapping if necessary."
  758.   (interactive "p")
  759.   (let ((goal-column (current-column))
  760.     goal-line)
  761.     ;; Determine goal line.
  762.     (forward-line-wrapping arg)
  763.     (db-jump-to-point)
  764.     (setq goal-line (current-line))
  765.     ;; Move to proper column.
  766.     (move-to-column goal-column)
  767.     (db-jump-to-point)
  768.     ;; If off the goal line, move back and as near to the goal column as possible.
  769.     (if (> (current-line) goal-line)
  770.     (progn
  771.       (db-previous-field-internal 1)
  772.       (goto-char (dbf-this-field-end-pos))))))
  773.  
  774. ;; (defun old-db-next-line-or-field (arg)
  775. ;;   "Move to ARGth next line.  If that would move out of the current field,
  776. ;; move to ARGth next field instead, wrapping if necessary."
  777. ;;   (interactive "p")
  778. ;;   (if (save-excursion
  779. ;;     (end-of-line)
  780. ;;     (eobp))
  781. ;;       (db-next-field arg)
  782. ;;     (progn
  783. ;;       (next-line arg)
  784. ;;       (if (> (point) (dbf-this-field-end-pos))
  785. ;;       (progn
  786. ;;         (goto-char dbf-this-field-beginning-pos)
  787. ;;         (db-next-field arg))))))
  788.  
  789. (defun db-move-to-field-exact (arg)
  790.   "Move to the ARGth field in the display.  Ignores reachablep."
  791.   (db-first-field-internal t)
  792.   (db-next-field-internal arg t)
  793.   (maybe-funcall dbf-enter-field-function dbf-this-field-index))
  794.  
  795. (defun db-next-field (arg)
  796.   "Move to ARGth next reachable field, wrapping if necessary.
  797. When called interactively, ARG defaults to 1."
  798.   (interactive "p")
  799.   (dbf-process-field-maybe t)
  800.   (goto-char dbf-this-field-beginning-pos)
  801.   (if (> arg 0)
  802.       (db-next-field-internal arg)
  803.     (db-previous-field-internal (- arg)))
  804.   ;; We have just moved to a new field, which certainly isn't modified yet.
  805.   (dbf-set-this-field-modified-p nil)
  806.   (maybe-funcall dbf-enter-field-function dbf-this-field-index))
  807.  
  808. ;; I believe this, or db-previous-field-internal, is called whenever a new
  809. ;; field is moved to.
  810.  
  811. ;; Arg should be positive.  Assumes point is at the beginning of the field.
  812. ;; If EXACT is non-nil, reachablep is ignored.
  813. (defun db-next-field-internal (arg &optional exact)
  814.   (while (> arg 0)
  815.     (if (skip-string-forward (aref dbf-fields-displayed dbf-this-field-index))
  816.     (progn
  817.       (setq dbf-this-field-index (1+ dbf-this-field-index)
  818.         arg (1- arg))
  819.       (if (= dbf-this-field-index dbf-displayspecs-length)
  820.           (progn
  821.         (if (not (skip-string-forward
  822.               (aref dbf-inter-field-text dbf-displayspecs-length)))
  823.             (db-parse-buffer-error
  824.              "Didn't find trailing text `%s' after field %s."
  825.              (aref dbf-inter-field-text dbf-displayspecs-length)
  826.              (1- dbf-displayspecs-length)))
  827.         (setq dbf-this-field-index 0)
  828.         (goto-char (dbf-point-min))))
  829.       (if (not (skip-string-forward
  830.             (aref dbf-inter-field-text dbf-this-field-index)))
  831.           (db-parse-buffer-error
  832.            "Didn't find field separator `%s' before field %s."
  833.            (aref dbf-inter-field-text dbf-this-field-index)
  834.            dbf-this-field-index))
  835.       ;;; Implement reachablep.
  836.       ;; *** Still need to guarantee no infinite loop.  Should go
  837.       ;; *** *somewhere* if all fields are unreachable somehow.
  838.       (if (not (or exact
  839.                (displayspec-reachablep
  840.             (aref dbf-displayspecs dbf-this-field-index))))
  841.           (setq arg (1+ arg)))
  842.       )
  843.       (db-parse-buffer-error
  844.        "Didn't find field %s text `%s'."
  845.        dbf-this-field-index
  846.        (aref dbf-fields-displayed dbf-this-field-index))))
  847.   (setq dbf-this-displayspec (aref dbf-displayspecs dbf-this-field-index)
  848.     dbf-this-field-beginning-pos (point))
  849.   (buffer-disable-undo (current-buffer))
  850.   (buffer-enable-undo)
  851.  
  852.   ;; These two implementations seem about equally vile.
  853.   ;; 1.
  854.   (if (looking-at (regexp-quote (aref dbf-fields-displayed dbf-this-field-index)))
  855.       (let ((end-of-match (match-end 0)))
  856.     (set-marker dbf-this-field-end-marker
  857.             (if (= end-of-match (point-max))
  858.             nil
  859.               (1+ end-of-match))
  860.             (current-buffer))))
  861.   ;;   ;; 2.
  862.   ;;   (if (skip-string-forward (aref dbf-fields-displayed dbf-this-field-index))
  863.   ;;       (progn
  864.   ;;     (set-marker dbf-this-field-end-marker
  865.   ;;             (if (eobp) nil (1+ (point)))
  866.   ;;             (current-buffer))
  867.   ;;      (goto-char dbf-this-field-beginning-pos)))
  868.   )
  869.  
  870. (defun db-previous-line-or-field (arg)
  871.   "Move to ARGth previous line.  If that would move out of the current field,
  872. move to the closest field to that, but not the current one, wrapping if necessary."
  873.   (interactive "p")
  874.   (let ((goal-column (current-column))
  875.     (vacated-line (current-line))
  876.     this-line)
  877.     (forward-line-wrapping (- arg))
  878.     (move-to-column goal-column)
  879.     (db-jump-to-point)
  880.     (setq this-line (current-line))
  881.     (if (= this-line vacated-line)
  882.     (progn
  883.       ;; We moved to a line containing no field, so db-jump-to-point
  884.       ;; put us in the field following point; ie, one on the line in
  885.       ;; which we started.  This is not the desired behavior.
  886.       ;; Get to a line containing a field.
  887.       (db-previous-field-internal 1)
  888.       (goto-char (dbf-this-field-end-pos))
  889.       ;; Go to the correct column.
  890.       (move-to-column goal-column)
  891.       ;; Avoid getting dumped back into this field.
  892.       (goto-char (min (point) (dbf-this-field-end-pos)))
  893.       ;; And end up there.
  894.       (db-jump-to-point)))))
  895.  
  896. ;; (defun old-db-previous-line-or-field (arg)
  897. ;;   "Move to ARGth previous line.  If that would move out of the current field,
  898. ;; move to ARGth previous field instead, wrapping if necessary."
  899. ;;   (interactive "p")
  900. ;;   ;; This is for when point is on the first buffer line and in a field.
  901. ;;   ;; I don't believe it works if the first field starts at the first character
  902. ;;   ;; of the data display buffer.
  903. ;;   (if (save-excursion (beginning-of-line) (bobp))
  904. ;;       (beginning-of-line)
  905. ;;     (previous-line arg))
  906. ;;   (if (< (point) dbf-this-field-beginning-pos)
  907. ;;       (progn
  908. ;;     (goto-char dbf-this-field-beginning-pos)
  909. ;;     (db-previous-field arg))))
  910.  
  911. (defun db-previous-field (&optional arg)
  912.   "Move to ARGth previous reachable field, wrapping if necessary.
  913. When called interactively, ARG defaults to 1."
  914.   (interactive "p")
  915.   (dbf-process-field-maybe t)
  916.   (goto-char dbf-this-field-beginning-pos)
  917.   (if (> arg 0)
  918.       (db-previous-field-internal arg)
  919.     (db-next-field-internal (- arg)))
  920.   (dbf-set-this-field-modified-p nil)
  921.   (maybe-funcall dbf-enter-field-function dbf-this-field-index))
  922.  
  923. ;; Arg should be positive.  Assumes point is at the beginning of the field.
  924. (defun db-previous-field-internal (arg)
  925.   (let ((prev-inter-field-text-beginning (marker-position
  926.                       dbf-this-field-end-marker)))
  927.     (if prev-inter-field-text-beginning
  928.     (setq prev-inter-field-text-beginning
  929.           (1- prev-inter-field-text-beginning)))
  930.     (while (> arg 0)
  931.       (if (skip-string-backward (aref dbf-inter-field-text dbf-this-field-index))
  932.       (progn
  933.         (setq prev-inter-field-text-beginning (point)
  934.           dbf-this-field-index (1- dbf-this-field-index)
  935.           arg (1- arg))
  936.         (if (< dbf-this-field-index 0)
  937.         (progn
  938.           (setq dbf-this-field-index (1- dbf-displayspecs-length))
  939.           (goto-char (point-max))
  940.           (if (skip-string-backward (aref dbf-inter-field-text
  941.                           dbf-displayspecs-length))
  942.               (setq prev-inter-field-text-beginning (point))
  943.             (db-parse-buffer-error
  944.              "Didn't find trailing text `%s' after field %s."
  945.              (aref dbf-inter-field-text dbf-displayspecs-length)
  946.              dbf-this-field-index))))
  947.         (if (not (skip-string-backward
  948.               (aref dbf-fields-displayed dbf-this-field-index)))
  949.         (db-parse-buffer-error
  950.          "Didn't find field %s text `%s'."
  951.          dbf-this-field-index
  952.          (aref dbf-fields-displayed dbf-this-field-index)))
  953.         ;;; Implement reachablep.
  954.         ;; *** Still need to guarantee no infinite loop.
  955.         (if (not (displayspec-reachablep
  956.               (aref dbf-displayspecs dbf-this-field-index)))
  957.         (setq arg (1+ arg)))
  958.         )
  959.     (db-parse-buffer-error
  960.      "Didn't find field separator `%s' before field %s."
  961.      (aref dbf-inter-field-text dbf-this-field-index)
  962.      dbf-this-field-index)))
  963.     (setq dbf-this-displayspec (aref dbf-displayspecs dbf-this-field-index)
  964.       dbf-this-field-beginning-pos (point))
  965.     (buffer-disable-undo (current-buffer))
  966.     (buffer-enable-undo)
  967.     (set-marker dbf-this-field-end-marker
  968.         (and prev-inter-field-text-beginning
  969.              (if (or (= 1 prev-inter-field-text-beginning)
  970.                  (= (point-max) prev-inter-field-text-beginning))
  971.              nil
  972.                (1+ prev-inter-field-text-beginning))))))
  973.  
  974. ;; Call this when the first field isn't the final destination, to avoid
  975. ;; calling the enter-field hook.
  976. ;;   "Move to first field.  Optional EXACT means ignore reachability."
  977. (defun db-first-field-internal (&optional exact)
  978.   (if dbf-this-field-index
  979.       (dbf-process-field-maybe t)
  980.     (db-edit-mode))
  981.   (setq dbf-this-field-index 0)
  982.   ;; We need this even if field-index was nil, because someone might have
  983.   ;; sneakily moved point.  (In fact, this is called after point is moved
  984.   ;; via mouse.)
  985.   (goto-char (dbf-point-min))
  986.   (if (not (skip-string-forward (aref dbf-inter-field-text 0)))
  987.       (db-parse-buffer-error
  988.        "Didn't find field separator `%s' before field %s."
  989.        (aref dbf-inter-field-text dbf-this-field-index)
  990.        dbf-this-field-index))
  991.   (db-next-field-internal 0)
  992.   ;; Implement reachablep
  993.   (if (not (or exact
  994.            (displayspec-reachablep
  995.         (aref dbf-displayspecs dbf-this-field-index))))
  996.       (db-next-field-internal 1))
  997.   (dbf-set-this-field-modified-p nil))
  998.  
  999. (defun db-first-field ()
  1000.   "Move to first field."
  1001.   (interactive)
  1002.   (db-first-field-internal nil)
  1003.   (maybe-funcall dbf-enter-field-function dbf-this-field-index))
  1004.  
  1005. ;; This isn't particularly efficient; ought to mirror db-first-field.  Oh, well.
  1006. (defun db-last-field ()
  1007.   "Move to last field."
  1008.   (interactive)
  1009.   (db-first-field-internal nil)
  1010.   (db-previous-field 1))
  1011.  
  1012. ;; ought to permit a numeric prefix argument.
  1013. (defun db-scroll-up ()
  1014.   "Like scroll-up, but also edits the nearest database field."
  1015.   (interactive)
  1016.   (scroll-up)
  1017.   (db-jump-to-point t))
  1018.  
  1019. ;; ought to permit a numeric prefix argument.
  1020. (defun db-scroll-down ()
  1021.   "Like scroll-down, but also edits the nearest database field."
  1022.   (interactive)
  1023.   (scroll-down)
  1024.   (db-jump-to-point t))
  1025.  
  1026. ;; If not in a field, could beep or go to nearest.  Could try to be clever
  1027. ;; about which field is "nearest" in some direction.  But not now.
  1028.  
  1029. ;; This has major problems if the record gets displayed, as the marker gets
  1030. ;; shoved to the front of the buffer.
  1031.  
  1032. ;; Does nothing if not in a database buffer.
  1033. (defun db-jump-to-point (&optional quietly)
  1034.   "If in a data display buffer, move to the field containing or following point.
  1035. In a summary buffer, move to the record displayed around point."
  1036.   (interactive)
  1037.   (cond ((db-data-display-buffer-p)
  1038.      (if (not (and dbf-this-field-index
  1039.                (and (<= dbf-this-field-beginning-pos (point))
  1040.                 (<= (point) (dbf-this-field-end-pos)))))
  1041.          ;; moving outside current field.
  1042.          (let ((new-point (point)))
  1043.            (set-marker dbf-moving-mark (point))
  1044.            ;; Go back to where we were:  if we were in a field, get back in it.
  1045.            (if dbf-this-field-index
  1046.            (goto-char dbf-this-field-beginning-pos))
  1047.            (if (and dbf-this-field-index
  1048.             (> (marker-position dbf-moving-mark) (point)))
  1049.            ;; We are in a field and moving forward
  1050.            (progn
  1051.              (dbf-process-field-maybe t)
  1052.              (goto-char dbf-this-field-beginning-pos))
  1053.          (db-first-field-internal nil))
  1054.            (db-debug-message "db-jump-to-point:  new-point = %d" new-point)
  1055.            ;; If the dbf-process-field-maybe redisplays the entire record,
  1056.            ;; the marker gets wiped out (points to the beginning of the
  1057.            ;; buffer, because the buffer is cleared and refilled).
  1058.            (let ((moving-pos (marker-position dbf-moving-mark)))
  1059.          (if (not (= 1 moving-pos))
  1060.              (setq new-point moving-pos)))
  1061.            (set-marker dbf-moving-mark nil)
  1062.            (while (and (> new-point (dbf-this-field-end-pos))
  1063.                  (< dbf-this-field-index (1- dbf-displayspecs-length)))
  1064.            ;; The EXACT argument is t so we don't infinite-loop when
  1065.            ;; the last field is unreachable.
  1066.            (db-next-field-internal 1 t)
  1067.            )
  1068.            (if (not (displayspec-reachablep dbf-this-displayspec))
  1069.              (progn
  1070.                ;; This message is getting wiped out by the
  1071.                ;; mouse-button-up event.  How can I fix this?
  1072.                ;; Hint:  Transposing the following two statements is
  1073.                ;; not the answer.
  1074.                (if (not quietly)
  1075.                (db-message "%s field is unreachable."
  1076.                        (fieldnumber->fieldname
  1077.                     (displayspec-record-index
  1078.                      dbf-this-displayspec)
  1079.                     dbc-database)))
  1080.                (db-next-field-internal 1)))
  1081.  
  1082.          (maybe-funcall dbf-enter-field-function dbf-this-field-index)
  1083.          ;; The max makes sure we're in a field, not beyond it.
  1084.          ;; The min is there only for the last field (because we could
  1085.          ;; be past it, in which case there's not a following field).
  1086.          (goto-char (min (max new-point dbf-this-field-beginning-pos)
  1087.                  (dbf-this-field-end-pos)))))
  1088.      ;; Check not in indentation even if didn't move to a new field.
  1089.      (if (dbf-in-indentation-p)
  1090.          (db-beginning-of-line-or-field)))
  1091.     ((db-summary-buffer-p)
  1092.      ;; This is wrong in the presence of omitted directory lines.
  1093.      (beginning-of-line)
  1094.      (let* ((lines (count-lines dbs-point (point)))
  1095.         (lines-signed (if (< dbs-point (point)) lines (- lines)))
  1096.         (difference (/ lines-signed dbfs-lines)))
  1097.        (goto-char dbs-point)
  1098.        (dbs-next-record-ignore-omitting difference)))))
  1099.  
  1100. (defvar db-mouse-buffer-switch-moves-point-p t
  1101.   "If this variable is non-nil, then whenever a mouse event causes a database
  1102. buffer to become the current buffer, `db-jump-to-point' is called, placing
  1103. point as close to the mouse click as possible.
  1104. If this variable is nil, then mouse clicks in a database buffer only move
  1105. point when they do not cause a buffer switch, that is, when that database
  1106. buffer was alrady the current buffer.
  1107.  
  1108. Set this variable if you prefer that switching to a database buffer via
  1109. mouse clicks does not move point.  (One reason besides personal preference
  1110. is the use of software such as Hyperbole which causes mouse events outside
  1111. the data display buffer to make it active.)")
  1112.  
  1113. ;; Best would be if we could know where the mouse was actually pressed or
  1114. ;; released.  I have no mouse support, so I don't know how to do this.  Ideas?
  1115.  
  1116. ;;   "Move to the field or record nearest the mouse position.
  1117. ;; See `db-jump-to-point' for more details."
  1118. (defun db-x-jump-to-point ()
  1119.   (interactive)
  1120.   (let ((here (point))
  1121.     (this-buffer (current-buffer)))
  1122.     (x-flush-mouse-queue)
  1123.     (if (if db-mouse-buffer-switch-moves-point-p
  1124.         ;; This window event caused point to move, or it switched buffers.
  1125.         (not (and (eq here (point))
  1126.               (eq this-buffer (current-buffer))))
  1127.       ;; This window event caused point to move, but not switch buffers.
  1128.       (and (not (eq here (point)))
  1129.            (eq this-buffer (current-buffer))))
  1130.     ;; db-jump-to-point is harmless if we're not in a database buffer.
  1131.     (db-jump-to-point))))
  1132. (proclaim-inline db-x-jump-to-point)
  1133.  
  1134.  
  1135. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1136. ;;; Movement within a field
  1137. ;;;
  1138.  
  1139. ;; These shouldn't be called if not on a field, so they don't check.
  1140.  
  1141. ;; This is so heavily called that I'm almost afraid to inline it for fear
  1142. ;; of code explosion.  Well, it's not that bad, I guess.
  1143. ;; Don't call this if not on a field.
  1144. (defun dbf-this-field-end-pos ()
  1145.   (let ((pos (marker-position dbf-this-field-end-marker)))
  1146.     (if pos
  1147.     (1- pos)
  1148.       (point-max))))
  1149. (proclaim-inline dbf-this-field-end-pos)
  1150.  
  1151. ;; So that this can look like a function, like dbf-this-field-end-pos does.
  1152. ;; I don't think I use this.
  1153. (defmacro dbf-this-field-beginning-pos ()
  1154.   'dbf-this-field-beginning-pos)
  1155.  
  1156. (defun dbf-this-field-indent ()
  1157.   (and (displayspec-indent dbf-this-displayspec)
  1158.        (if (numberp (displayspec-indent dbf-this-displayspec))
  1159.        (displayspec-indent dbf-this-displayspec)
  1160.      (save-excursion
  1161.        (goto-char dbf-this-field-beginning-pos)
  1162.        (current-column)))))
  1163.  
  1164. ;;;
  1165. ;;; Checking
  1166. ;;;
  1167.  
  1168. ;; Which way should the default go on these functions?
  1169.  
  1170. ;; Moves point to end of field if it's beyond that.
  1171. (defun dbf-check-if-beyond-field (&optional quietly)
  1172.   (let ((end-pos (dbf-this-field-end-pos)))
  1173.     (if (> (point) end-pos)
  1174.     (progn
  1175.       (goto-char end-pos)
  1176.       (if (not quietly)
  1177.           (dbf-inform-outside-field "End of field."))))))
  1178.  
  1179. ;; Moves point to beginning of field if it's before that.
  1180. (defun dbf-check-if-before-field (&optional quietly)
  1181.   (if (< (point) dbf-this-field-beginning-pos)
  1182.       (progn
  1183.     (goto-char dbf-this-field-beginning-pos)
  1184.     (if (not quietly)
  1185.         (db-message "Beginning of field.")))))
  1186.  
  1187. ;;   "If point is outside current field, it is move to the field's limit."
  1188. (defun dbf-check-if-outside-field (&optional quietly)
  1189.   (dbf-check-if-before-field quietly)
  1190.   (dbf-check-if-beyond-field quietly))
  1191. (proclaim-inline dbf-check-if-outside-field)
  1192.  
  1193. ;; So keyboard macros terminate.
  1194. (deflocalvar dbf-field-boundary-action 'error
  1195.   "Controls action when point attempts to leave a field.
  1196. One of nil, 'message, 'beep, 'ding, 'error.
  1197. 'beep and 'ding are identical and also show a message.
  1198. Having a variable is overkill, but I don't yet know what the Right Thing is.")
  1199.  
  1200. (defun dbf-inform-outside-field (message)
  1201.   (cond ((eq 'error dbf-field-boundary-action)
  1202.      (error message))
  1203.     ((eq 'ding dbf-field-boundary-action)
  1204.      (db-message message)
  1205.      (ding))
  1206.     ((eq 'beep dbf-field-boundary-action)
  1207.      (db-message message)
  1208.      (beep))
  1209.     ((eq 'message dbf-field-boundary-action)
  1210.      (db-message message))
  1211.     ((eq nil dbf-field-boundary-action)
  1212.      nil)
  1213.     (t
  1214.      (error "What value does this dbf-field-boundary-action value mean?  %s"
  1215.         dbf-field-boundary-action))))
  1216.  
  1217. ;;;
  1218. ;;; Movement
  1219. ;;;
  1220.  
  1221. (defun db-beginning-of-field ()
  1222.   "Move to the beginning of the current field."
  1223.   (interactive)
  1224.   (goto-char dbf-this-field-beginning-pos))
  1225. (proclaim-inline db-beginning-of-field)
  1226.  
  1227. (defun db-end-of-field ()
  1228.   "Move to the end of the current field."
  1229.   (interactive)
  1230.   (goto-char (dbf-this-field-end-pos)))
  1231. (proclaim-inline db-end-of-field)
  1232.  
  1233. (defun dbf-in-indentation-p ()
  1234.   (let ((amt (dbf-this-field-indent)))
  1235.     (and amt
  1236.      (> amt 0)
  1237.      ;; Replaced by following lines.
  1238.      ;; (looking-back-at (concat "^" (space-maybe-regexp (1- amt))))
  1239.      (looking-back-at "^ +")
  1240.      ;; Probably faster than (length (match-string 0)).
  1241.      (< (current-column) amt))))
  1242.  
  1243. (defun db-beginning-of-line-or-field ()
  1244.   "Move to the beginning of the current line of the current field."
  1245.   (interactive)
  1246.   (beginning-of-line)
  1247.   (skip-regexp-forward (space-maybe-regexp (dbf-this-field-indent)))
  1248.   (dbf-check-if-outside-field t))
  1249.  
  1250. (defun db-end-of-line-or-field (arg)
  1251.   "Move to the end of the current line of the current field."
  1252.   (interactive "p")
  1253.   ;; Maybe just use (min end-of-line-pos end-of-field-pos) to avoid the noise.
  1254.   (end-of-line arg)
  1255.   (dbf-check-if-outside-field t))
  1256.  
  1257. (defun db-forward-char (arg)
  1258.   "Like forward-char, but won't go outside field."
  1259.   (interactive "p")
  1260.   (if (< arg 0)
  1261.       (db-backward-char (- arg))
  1262.     (let ((indent (dbf-this-field-indent)))
  1263.       (while (> arg 0)
  1264.     (if (eobp)
  1265.         ;; This is so we get "End of field" instead of "End of buffer".
  1266.         (progn
  1267.           (setq arg 0)
  1268.           (dbf-inform-outside-field "End of field."))
  1269.       (progn
  1270.         (forward-char 1)
  1271.         (skip-regexp-forward (concat "^" (space-maybe-regexp indent)))
  1272.         (setq arg (1- arg)))))
  1273.       (dbf-check-if-outside-field))))
  1274.  
  1275. (defun db-backward-char (arg)
  1276.   "Like backward-char, but won't go outside field."
  1277.   (interactive "p")
  1278.   (if (< arg 0)
  1279.       (db-forward-char (- arg))
  1280.     (let ((indent (dbf-this-field-indent)))
  1281.       (while (> arg 0)
  1282.     (if (bobp)
  1283.         ;; This is so we get the error "Beginning of field"
  1284.         ;; instead of "Beginning of buffer".
  1285.         (progn
  1286.           (setq arg 0)
  1287.           (dbf-inform-outside-field "Beginning of field."))
  1288.       (progn
  1289.         ;; Is there a better way to do this check?
  1290.         (skip-regexp-backward (concat "^" (space-maybe-regexp indent)))
  1291.         (backward-char 1)
  1292.         (setq arg (1- arg)))))
  1293.       (dbf-check-if-outside-field))))
  1294.  
  1295.  
  1296. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1297. ;;; Editing
  1298. ;;;
  1299.  
  1300. (defun db-delete-char (arg)
  1301.   (interactive "p")
  1302.   "Like delete-char, but won't delete outside the field."
  1303.   (delete-region (point) (progn (db-forward-char arg) (point))))
  1304.  
  1305. (defun db-backward-delete-char (arg)
  1306.   (interactive "p")
  1307.   "Like delete-backward-char, but won't delete outside the field."
  1308.   (delete-region (point) (progn (db-backward-char arg) (point))))
  1309.  
  1310. (defun db-forward-word (arg)
  1311.   "Like forward-word, but won't go outside field."
  1312.   (interactive "p")
  1313.   (forward-word arg)
  1314.   (dbf-check-if-outside-field))
  1315.  
  1316. (defun db-backward-word (arg)
  1317.   "Like backward-word, but won't go outside field."
  1318.   (interactive "p")
  1319.   (db-forward-word (- arg)))
  1320.  
  1321. (defun db-copy-region-as-kill (beg end)
  1322.   "Save the region as if killed, but don't kill it."
  1323.   (interactive "r")
  1324.   (if (eq last-command 'db-kill-region)
  1325.       (kill-append (unindentify (buffer-substring beg end)) (< end beg))
  1326.     (setq kill-ring (cons (unindentify (buffer-substring beg end)) kill-ring))
  1327.     (if (> (length kill-ring) kill-ring-max)
  1328.     (setcdr (nthcdr (1- kill-ring-max) kill-ring) nil)))
  1329.   (setq this-command 'db-kill-region)
  1330.   (setq kill-ring-yank-pointer kill-ring))
  1331.  
  1332. (defun db-kill-region (beg end)
  1333.   "Kill between point and mark.
  1334. The text is deleted but saved in the kill ring.  See `kill-region' for details."
  1335.   (interactive "*r")
  1336.   (db-copy-region-as-kill beg end)
  1337.   (delete-region beg end))
  1338.  
  1339. (defun db-kill-word (arg)
  1340.   "Like kill-word, but won't delete outside the field."
  1341.   (interactive "p")
  1342.   (db-kill-region (point) (progn (db-forward-word arg) (point))))
  1343.  
  1344. (defun db-backward-kill-word (arg)
  1345.   "Like backward-kill-word, but won't delete outside the field."
  1346.   (interactive "p")
  1347.   (db-kill-word (- arg)))
  1348.  
  1349. (defun db-kill-line (arg)
  1350.   "Like kill-line, but won't delete outside the field."
  1351.   (interactive "p")
  1352.   (let ((here (point)))
  1353. ;;     (if (and (= arg 1)
  1354. ;;          (looking-at (concat "[ \t]*\n"
  1355. ;;                  (space-maybe-regexp (dbf-this-field-indent)))))
  1356. ;;     (progn
  1357. ;;       (goto-char (match-end 0))
  1358. ;;       (dbf-check-if-outside-field))
  1359. ;;       (db-end-of-line-or-field arg))
  1360.     (db-end-of-line-or-field arg)
  1361.     (if (< (point) (dbf-this-field-end-pos))
  1362.     (skip-regexp-forward
  1363.      (concat "[ \t]*\n" (space-maybe-regexp (dbf-this-field-indent)))))
  1364.     (db-kill-region here (point))))
  1365.  
  1366. (defun db-kill-to-end ()
  1367.   "Kill from point to the end of the current field."
  1368.   (interactive)
  1369.   (db-kill-region (point) (dbf-this-field-end-pos)))
  1370.  
  1371.  
  1372. (defun db-newline (arg)
  1373.   "Insert a newline.  Will not make the current field too tall.
  1374. If the current field's maximum height is 1 line, move to the next field instead."
  1375.   (interactive "p")
  1376.   ;; ignores the argument
  1377.   (let ((max-height (displayspec-max-height dbf-this-displayspec)))
  1378.     (if (or (not max-height)
  1379.         (< (count-lines dbf-this-field-beginning-pos (dbf-this-field-end-pos))
  1380.            max-height))
  1381.     (let ((indent (dbf-this-field-indent)))
  1382.       (newline 1)
  1383.       ;;; I'm having second thoughts about this.
  1384.       ;;     ;; this always returns t
  1385.       ;;     (looking-at (space-maybe-regexp indent))
  1386.       ;;     (replace-match (make-string indent ? ))
  1387.       (if indent (db-old-insert (make-string indent ? ))))
  1388.       (if (= 1 max-height)
  1389.       (db-next-field 1)
  1390.     (db-message "Field is at maximum height already.")))))
  1391.  
  1392. ;; save-excursion wasn't doing the right thing here because it makes a
  1393. ;; marker and the insertion occurred before the marker:
  1394. ;;   (save-excursion
  1395. ;;     (db-newline arg))
  1396.  
  1397. (defun db-open-line (arg)
  1398.   "Insert a newline and leave point before it.
  1399. Will not make the current field too tall."
  1400.   (interactive "p")
  1401.   (let ((here (point)))
  1402.     (db-newline arg)
  1403.     (goto-char here)))
  1404.  
  1405.  
  1406. (if (not (fboundp 'db-old-insert))
  1407.     (fset 'db-old-insert (symbol-function 'insert)))
  1408.  
  1409. ;; These are lifted from simple.el.
  1410. ;; This is a silly place for these functions to be defined.
  1411.  
  1412. ;;; Superceded by db-insert-item
  1413. ;; (defun db-insert-string (string)
  1414. ;;   (db-old-insert (indentify-absolute string)))
  1415.  
  1416. (defun db-insert-item (string-or-char)
  1417.   (db-old-insert
  1418.    (indentify-absolute
  1419.     (if (stringp string-or-char)
  1420.     string-or-char
  1421.       (char-to-string string-or-char)))))
  1422.  
  1423. (defun db-insert (&rest args)
  1424.   "Any number of args, strings or chars.  Insert them after point, moving point forward.
  1425. Does special manipulations in database data display buffers."
  1426.   (if (db-data-display-buffer-p)
  1427.       (mapcar (function db-insert-item)
  1428.           args)
  1429.     ;; Reduce total number of function applications by not using mapcar here.
  1430.     (apply (function db-old-insert) args)))
  1431.  
  1432. (fset 'insert 'db-insert)
  1433.  
  1434.  
  1435. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1436. ;;; Value processing for fields and records
  1437. ;;;
  1438.  
  1439. ;; I should also check that I can still see the inter-field-text after the
  1440. ;; end of the field text.  If I'm paranoid (or if there is little or no
  1441. ;; inter-field-text), check that I can see the next field text as well.
  1442.  
  1443. ;; Make the return value of this meaningful.
  1444. ;;   "Set the value of the current record from the current field.
  1445. ;; If arg SET-FIELD-TEXT-P is non-nil, update the display as well.
  1446. ;; Return t if field is unmodified or text is OK; nil otherwise.
  1447. ;; May move point."
  1448. (defun dbf-process-field-maybe (set-field-text-p)
  1449.   (if (dbf-this-field-modified-p)
  1450.       (dbf-process-field set-field-text-p)
  1451.     t))
  1452. (proclaim-inline dbf-process-field-maybe)
  1453.  
  1454.  
  1455. ;; Should only be called if the field is really modified, or appears so.
  1456. (defun dbf-process-field (set-field-text-p)
  1457.  
  1458.   ;; I used to check for dbf-this-displayspec; but I think it cannot be non-nil
  1459.   ;; if (dbf-this-field-modified-p) returns t (and all is well).
  1460.   ;; Once I thought to have region-change-hook set dbf-this-field-modified-p.
  1461.  
  1462.   (if (or (< (point) dbf-this-field-beginning-pos)
  1463.       (> (point) (dbf-this-field-end-pos)))
  1464.       (db-parse-buffer-error "Point was outside (%d) of current field (%d - %d)."
  1465.                  (point)
  1466.                  dbf-this-field-beginning-pos
  1467.                  (dbf-this-field-end-pos)))
  1468.  
  1469.   ;; This field has been modified, and point is in the field as expected.
  1470.   (if (not (equal (dbf-this-field-text)
  1471.           (aref dbf-fields-displayed dbf-this-field-index)))
  1472.       ;; Perhaps it would behoove us to have an additional check with
  1473.       ;; unrect text, but I don't bother to remember it anywhere.
  1474.       (let* ((field-value (display->actual-call
  1475.                (displayspec-display->actual dbf-this-displayspec)
  1476.                (dbf-this-field-text-unrect)
  1477.                (aref (dbf-displayed-record) dbf-this-field-index)
  1478.                (dbf-displayed-record)
  1479.                dbf-this-field-index))
  1480.          (record-index (displayspec-record-index dbf-this-displayspec))
  1481.          (old-field-value (aref (dbf-displayed-record) record-index))
  1482.          (saved-modified-p dbf-this-record-modified-p))
  1483.     (db-debug-message "dbf-process-field-maybe:  record-index = %s"
  1484.               record-index)
  1485.     (db-debug-message "dbf-process-field-maybe:  field-value = %s"
  1486.               field-value)
  1487.     (if (not (equal field-value old-field-value))
  1488.         ;; The new value is different from the old.
  1489.         (progn
  1490.           ;; Use dbf-set-this-record-modified-p in order to call
  1491.           ;; dbf-set-this-record-modified-function when necessary, and to
  1492.           ;; move the record into dbf-this-record.  (Should I be doing this
  1493.           ;; before calling the constraint function?)
  1494.           (dbf-set-this-record-modified-p t)
  1495.           (record-set-field-from-index
  1496.            dbf-this-record record-index field-value dbc-database)
  1497.  
  1498.           (if set-field-text-p
  1499.           (aset dbf-fields-displayed dbf-this-field-index
  1500.             (displayspec->displayed-rep dbf-this-displayspec
  1501.                             dbf-this-record)))
  1502.           ;; No need to do redisplay before the change-hooks are
  1503.           ;; called since the user's version is already onscreen
  1504.           ;; and that will be very similar indeed to the display
  1505.           ;; text.
  1506.           (db-debug-message "dbf-redisplay-entire-record-p = %s"
  1507.                 dbf-redisplay-entire-record-p)
  1508.           (if (not saved-modified-p)
  1509.           (setq dbf-redisplay-entire-record-p
  1510.             (or (maybe-funcall dbf-first-change-function
  1511.                        (dbf-this-field-name)
  1512.                        old-field-value
  1513.                        field-value)
  1514.                 dbf-redisplay-entire-record-p)))
  1515.           (db-debug-message "after checking dbf-this-record-modified-p, dbf-redisplay-entire-record-p = %s"
  1516.                 dbf-redisplay-entire-record-p)
  1517.           (setq dbf-redisplay-entire-record-p
  1518.             (or (maybe-funcall dbf-every-change-function
  1519.                        (dbf-this-field-name)
  1520.                        old-field-value
  1521.                        field-value)
  1522.             dbf-redisplay-entire-record-p))
  1523.           (db-debug-message "dbf-redisplay-entire-record-p = %s"
  1524.                 dbf-redisplay-entire-record-p)
  1525.           (setq dbf-redisplay-entire-record-p
  1526.             (or (maybe-funcall (aref dbf-change-functions record-index)
  1527.                        (dbf-this-field-name)
  1528.                        old-field-value
  1529.                        field-value)
  1530.             dbf-redisplay-entire-record-p))
  1531.           ))
  1532.     (db-debug-message "dbf-redisplay-entire-record-p = %s, set-field-text-p = %s"
  1533.               dbf-redisplay-entire-record-p set-field-text-p)
  1534.     ;; The text is different; the value may or may not have differed.
  1535.     ;; Display the standard representation for this value, which has
  1536.     ;; already been computed.
  1537.     (if set-field-text-p
  1538.         ;; Perhaps add some sort of test of
  1539.         ;; dbf-before-display-record-function here:  if non-nil, then
  1540.         ;; we ought to be redisplaying regardless of anything else.
  1541.         (if (not (dbf-redisplay-entire-record-maybe))
  1542.         ;; set-field-text always returns nil
  1543.         (dbf-set-this-field-text
  1544.          (aref dbf-fields-displayed dbf-this-field-index))))
  1545.     (dbf-set-this-field-modified-p nil))
  1546.     ;; Field is unchanged, so mark it unmodified.
  1547.     (dbf-set-this-field-modified-p nil)
  1548.     ))
  1549.  
  1550. ;;   "If  dbf-redisplay-entire-record-p  is non-nil, redisplay current record
  1551. ;; and return t; otherwise return nil."
  1552. (defun dbf-redisplay-entire-record-maybe ()
  1553.   (if dbf-redisplay-entire-record-p
  1554.       (progn
  1555.     (db-debug-message "Redisplaying entire record.")
  1556.     (setq dbf-redisplay-entire-record-p nil)
  1557.     (db-emergency-restore-format t)
  1558.     t)))
  1559.  
  1560.  
  1561. ;; This should be a dbc- function, perhaps.
  1562. ;; We should be able to say, NO, we can not commit the changes to the
  1563. ;; current record, and we cannot proceed (if d-p-c-r-m returns t).
  1564. ;; Currently, all callers IGNORE return value.
  1565.  
  1566. ;; Amazingly, this does the right thing when called in the summary buffer
  1567. ;; -- that is, it does nothing.  This is because dbc-index is nil there.
  1568. ;;   "Commit changes to the record being displayed and edited.
  1569. ;; If the current record (whatever is returned by `dbf-displayed-record') is a
  1570. ;; modified copy of a database record, this copies it back to
  1571. ;; dbf-this-record-original, which is the original database record.  Thus,
  1572. ;; this procedure modifies the database by side effect.
  1573. ;; Return t if successful, nil otherwise.
  1574. ;; Updates the display if SET-TEXT-P is non-nil."
  1575. (defun dbf-process-current-record-maybe (set-text-p)
  1576.   (if dbc-index
  1577.       (progn
  1578.     (dbf-process-field-maybe set-text-p)
  1579.  
  1580.     (if dbf-this-record-modified-p
  1581.         (progn
  1582.           ;; Do any programmer-requested checking or postprocessing here.
  1583.           (maybe-funcall dbf-after-record-change-function
  1584.                  (dbf-displayed-record))
  1585.           (copy-record-to-record dbf-this-record dbf-this-record-original)
  1586.           (link-set-summary dbc-link nil)
  1587.           ;; (dbf-set-summary-out-of-date-p)
  1588.           (dbf-update-summary-item dbc-index dbc-link)
  1589.           ;; should set link-omittedp too.
  1590.           ;; [Now moot; besides, I decided this wasn't so horrible.]
  1591.           ;; [The question really concerns dbf-this-record-modified-p.]
  1592.           ;; Do I really want to be setting dbf-this-record to nil?  I
  1593.           ;; dunno, since if the user immediately starts editing this
  1594.           ;; record again (admittedly unlikely given that this function
  1595.           ;; is usually only called when moving off a record and when
  1596.           ;; saving to a file), then I'd save some time.
  1597.           ;; Actually I probably want to set it to nil since
  1598.           ;; moving from record to record doesn't do so.
  1599.           (dbc-set-database-modified-p t)
  1600.           (setq dbf-this-record-modified-p nil)
  1601.           (dbf-set-this-field-modified-p nil))))
  1602.     ;; The displayed record isn't associated with a database record.
  1603.     ;; OK if it isn't modified or the user says so.
  1604.     ;; This shouldn't be called on a non-database record anyway.
  1605.     ;; But I don't know that the info is about to be abandoned in the
  1606.     ;; unlikely event that this is called.
  1607.     (or (not dbf-this-record-modified-p)
  1608.     (y-or-n-p "Abandon the displayed information? "))))
  1609.  
  1610.  
  1611.  
  1612. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1613. ;;; Undoing changes
  1614. ;;;
  1615.  
  1616. ;; I don't think this is needed; just use C-x u.  Wrong:  there will be
  1617. ;; something like this for after moving off and returning to a modified
  1618. ;; record.
  1619.  
  1620. (defun db-revert-field (&optional quietly)
  1621.   "Replace the onscreen text in this field with that of the underlying record.
  1622. In other words, undo any changes made since entering this field."
  1623.   (interactive)
  1624.  
  1625.   (if (dbf-this-field-modified-p)
  1626.       (progn
  1627.     (dbf-set-this-field-text
  1628.      (aref dbf-fields-displayed dbf-this-field-index))
  1629.     (dbf-set-this-field-modified-p nil)
  1630.     (if (not quietly)
  1631.         (db-message "Reverted %s." (dbf-this-field-name))))
  1632.     (if (not quietly)
  1633.     (db-message "Can't revert %s; no changes since moving onto it."
  1634.          (dbf-this-field-name)))))
  1635.  
  1636. (defun db-revert-record ()
  1637.   "Set the record to be the same as the corresponding one in the database.
  1638. In other words, undo any changes made since entering this record."
  1639.   (interactive)
  1640.   ;; This work might be wasted, but since usually this will be called from
  1641.   ;; view mode (not inside a record), it won't have any effect, and if
  1642.   ;; called from edit mode and only one field is modified, it's a win.
  1643.   (db-revert-field t)
  1644.   (if dbf-this-record-modified-p
  1645.       (let ((buffer-read-only nil))
  1646.     (setq dbf-this-record-modified-p nil)
  1647.     (display-record (dbf-displayed-record) t)
  1648.     (if dbf-this-field-index
  1649.         (db-move-to-field-exact dbf-this-field-index))
  1650.     (db-message "Reverted record."))
  1651.     (db-message "Can't revert this record; no changes since selecting it.")))
  1652.  
  1653.  
  1654. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1655. ;;; Set displayspec from string
  1656. ;;;
  1657.  
  1658.  
  1659. ;; This doesn't work yet for multichar alternatives.
  1660.  
  1661. ;; Do I really want displaytypes to be symbols?  Strings might well be easier.
  1662.  
  1663. ;;   "Return the displaytype (a symbol) corresponding to STRING.
  1664. ;; Non-strings are returned unchanged."
  1665. (defun string->displaytype (string)
  1666.   (if (stringp string)
  1667.       (cond ((string= string "#")
  1668.           'integer)
  1669.         ((string= string "$")
  1670.           'number)
  1671.         ((string= string "\"")
  1672.           'string)
  1673.         ((string= string "'")
  1674.           'one-line-string)
  1675.         ((string-match "^\\[.*\\]$" string)
  1676.          (list 'alternative-one-char (substring string 1 -1)))
  1677.         (t
  1678.          (intern string)))
  1679.     string))
  1680.  
  1681. (defun displaytype->displayspec (displaytype)
  1682.   "Return a copy of the displayspec corresponding to string or symbol DISPLAYTYPE.
  1683. Return nil if there's no corresponding displayspec."
  1684.   (let ((displayspec
  1685.      (cdr (assoc (string->displaytype displaytype) db-displaytypes))))
  1686.     (cond ((displayspec-p displayspec)
  1687.        (copy-displayspec displayspec))
  1688.       ((and displayspec (symbolp displayspec))
  1689.        ;; make a recursive call
  1690.        (displaytype->displayspec displayspec)))))
  1691.  
  1692. ;;; Used to err.
  1693. ;; (defun displaytype->displayspec (displaytype)
  1694. ;;   "Return a copy of the displayspec corresponding to string or symbol DISPLAYTYPE."
  1695. ;;   (copy-displayspec (or (cdr (assoc (string->displaytype displaytype)
  1696. ;;                   db-displaytypes))
  1697. ;;               (error "%s is not a known displaytype." displaytype))))
  1698.  
  1699.  
  1700. ;; Return a displayspec.
  1701. ;;   "Create a displayspec from a specification string."
  1702. (defun make-displayspec-from-string (displayspec-string database)
  1703.   (if (not (string-match (concat "^" displayspec-regexp "$")
  1704.              displayspec-string))
  1705.       (error "`%s' doesn't look like a field specification"
  1706.          displayspec-string))
  1707.   (make-displayspec-from-string-internal displayspec-string database))
  1708.  
  1709. ;; Assumes the match-data is set.  DISPLAYSPEC-STRING is nil if from the buffer.
  1710. (defun make-displayspec-from-string-internal (displayspec-string database)
  1711.   (let* ((fieldname (match-string displayspec-regexp-fieldname
  1712.                   displayspec-string))
  1713.      (abbrev-assoc (assoc fieldname dbf-fieldabbrevs)))
  1714.     (if abbrev-assoc
  1715.     (copy-displayspec (cdr abbrev-assoc))
  1716.       (progn
  1717.     ;; get rid of leading backslash
  1718.     (setq fieldname (intern (substring fieldname 1)))
  1719.     (let ((index (and database (fieldname->fieldnumber fieldname database)))
  1720.           displayspec)
  1721.       (if (and database (not index))
  1722.           (error "%s is not a field or field abbreviation."
  1723.              fieldname))
  1724.       (db-debug-message "About to mdftao %s (%s); args = %s %s"
  1725.                 fieldname
  1726.                 (match-string displayspec-regexp-fieldname displayspec-string)
  1727.                 (database-recordfieldspec-type database index)
  1728.                 (match-string-maybe displayspec-regexp-fieldoptions
  1729.                         displayspec-string))
  1730.       (setq displayspec
  1731.         (make-displayspec-from-type-and-options
  1732.          (database-recordfieldspec-type database index)
  1733.          (match-string-maybe displayspec-regexp-fieldoptions
  1734.                      displayspec-string)))
  1735.       (if (not displayspec)
  1736.           (error "Type %s in field %d (%s) not recognized."
  1737.              (database-recordfieldspec-type database index)
  1738.              fieldname index))
  1739.       (displayspec-set-record-index displayspec index)
  1740.       displayspec)))))
  1741.  
  1742.  
  1743. ;; This is abstracted out for the use of define-displaytype and others.
  1744.  
  1745. (defun make-displayspec-from-type-and-options (displaytype optionstring &optional notype-ok)
  1746.   ;; Either DISPLAYTYPE or OPTIONSTRING must specify a type, unless
  1747.   ;; optional argument NOTYPE-OK is specified, in which case an empty
  1748.   ;; displayspec may be returned.
  1749.  
  1750.   ;; Ordinarily (for instance, when this is being called to parse part of a
  1751.   ;; format), NOTYPE-OK should not be specified, so that invalid
  1752.   ;; displaytypes aren't created.
  1753.  
  1754.   ;; A type in OPTIONSTRING overrides DISPLAYTYPE.
  1755.  
  1756.   (if (not optionstring)
  1757.       (if displaytype
  1758.       (or (displaytype->displayspec displaytype)
  1759.           (error "No such displaytype as `%s'." displaytype))
  1760.     (make-displayspec))
  1761.     (let (displayspec match-end-0)
  1762.       ;; set the displayspec
  1763.       ;; Is it cheaper to do the concatenation or to test for the result being 0?
  1764.      
  1765.       ;; note tricky sequencing
  1766.       (if (and (string-match (concat "^" displaytype-regexp) optionstring)
  1767.            (setq displayspec (displaytype->displayspec
  1768.                 (string->displaytype
  1769.                  (match-string 1 optionstring)))))
  1770.       (setq optionstring (substring optionstring (match-end 0)))
  1771.     (if displaytype
  1772.         (setq displayspec (displaytype->displayspec displaytype))
  1773.       (error "No type specified in `%s'." optionstring)))
  1774.      
  1775.       (while (not (equal "" optionstring))
  1776.     (if (not (string-match (concat "^" fieldoption-regexp) optionstring))
  1777.         (error "`%s' isn't an optional field specification."
  1778.            optionstring))
  1779.     (setq match-end-0 (match-end 0))
  1780.     ;; (db-debug-message "mdftao:  match-data = %s" (show-match-data optionstring))
  1781.     ;; Function in the third optspec position might clobber match-data.
  1782.     (update-displayspec-from-optspec-and-value
  1783.      displayspec
  1784.      (or (assoc (match-string fieldoption-regexp-symbol optionstring)
  1785.             optspec-list)
  1786.          (error "%s isn't a valid optional field specifier name or type."
  1787.             (match-string fieldoption-regexp-symbol optionstring)))
  1788.      (match-string-maybe fieldoption-regexp-equals optionstring))
  1789.     (setq optionstring (substring optionstring match-end-0)))
  1790.       displayspec)))
  1791.  
  1792.  
  1793. (defun update-displayspec-from-optspec-and-value (displayspec optspec value)
  1794.   (let ((accessor (optspecinfo-accessor optspec))
  1795.     (value (funcall (optspecinfo-specfunction optspec) value)))
  1796.     (cond ((numberp accessor)
  1797.        (aset displayspec accessor value))
  1798.       ((functionp accessor)
  1799.        (funcall accessor displayspec value))
  1800.       ((listp accessor)
  1801.        ;; list of numbers
  1802.        (while accessor
  1803.          (aset displayspec (car accessor) value)
  1804.          (setq accessor (cdr accessor))))
  1805.       (t
  1806.        (error "Unrecognized optspecinfo-accessor %s." accessor)))))
  1807.  
  1808.  
  1809. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1810. ;;; Read a format file
  1811. ;;;
  1812.  
  1813. ;; Called by read-database-file, make-similar-database.
  1814.  
  1815. ;; Perhaps this should add the result to the data-display-buffers slot of the
  1816. ;; database as well.
  1817. ;; The format file should exist.
  1818. ;;   "Create and return a data display buffer.
  1819. ;; This is only called when a brand-new data display buffer is being created, not
  1820. ;; when one is being refreshed.
  1821. ;; Arguments are FORMAT-FILE DATABASE NEW-DATABASE-P.
  1822. ;; If NEW-DATABASE-P is non-nil, then the database's auxiliary file is read
  1823. ;; and its field variables are set.
  1824. ;; 
  1825. ;; WARNING:  If the format file's local variables set particular database
  1826. ;; slots \(such as fieldnames\), and NEW-DATABASE-P is nil, then the database
  1827. ;; may be left in an inconsistent state.  The \"primary\" format, which is
  1828. ;; read in before the database is, should perform any such neccessary
  1829. ;; actions."
  1830. (defun db-setup-data-display-buffer (format-file database new-database-p)
  1831.  
  1832.   (setq format-file (expand-file-name format-file))
  1833.  
  1834.   (if (not (file-readable-p format-file))
  1835.       (error "Can't read format file `%s'." format-file))
  1836.  
  1837.   ;; Do I want switch-to-buffer instead?
  1838.   (set-buffer (db-make-data-display-buffer database new-database-p))
  1839.   (setq buffer-read-only nil)
  1840.  
  1841.   (insert-file-contents format-file nil)
  1842.   (setq dbf-format-file format-file)
  1843.  
  1844.   (if new-database-p (read-db-aux-file database))
  1845.  
  1846.   (db-debug-message "db-setup-data-display-buffer:  hacking local variables")
  1847.   (really-hack-local-variables)
  1848.   ;; (db-debug-message "hacked.")
  1849.  
  1850.   (if new-database-p
  1851.       (progn
  1852.     ;; Initialize database variables.  We didn't do this before because
  1853.     ;; they may depend on some values set in the format file.
  1854.     (if (not (database-internal-file-layout-p database))
  1855.         (db-set-field-variables database))
  1856.  
  1857.     ;; Initialize local variables.
  1858.     ;; These don't need to be changed from format to format.
  1859.     (setq dbf-change-functions (make-vector (database-no-of-fields database)
  1860.                         nil)
  1861.           dbf-this-record (make-record dbc-database))))
  1862.  
  1863.   (db-setup-ddb-parse-displayspecs database)
  1864.  
  1865.   ;; Joe Wells says:  Starts in view mode but buffer is writable.  I don't
  1866.   ;; really understand how the situation arises, but this closes off part
  1867.   ;; of the problem.  Another patch is required elsewhere.
  1868.   (setq buffer-read-only t)
  1869.   (current-buffer))
  1870.  
  1871. ;; Makes the buffer the current buffer as well.
  1872. ;; Sets dbf-change-functions and dbf-this-record only if new-database-p is nil.
  1873. (defun db-make-data-display-buffer (database new-database-p)
  1874.   (in-buffer (create-file-buffer (database-file database))
  1875.     (let ((dir (file-name-directory (database-file database))))
  1876.       (if dir
  1877.       (setq default-directory (expand-file-name dir))))
  1878.     (setq dbc-database database)
  1879.     (if (not new-database-p)
  1880.     ;; These are per-data-display-buffer variables.
  1881.     (setq dbf-change-functions (make-vector (database-no-of-fields database)
  1882.                         nil)
  1883.           dbf-this-record (make-record dbc-database)))
  1884.     ;; Given that lots of variables aren't set yet, I believe this works only
  1885.     ;; if buffer-modified-p is nil, which it is for brand-new buffers.
  1886.     (database-mode)
  1887.     (current-buffer)))
  1888.  
  1889. ;; I'm not clear exactly what is being abstracted out here.  I want to
  1890. ;; support muliple formats eventually.
  1891.  
  1892. ;; The dbf variables that need to change when the display format changes are:
  1893. ;; ...
  1894. ;; I hope the above list is exactly what is set by this function.
  1895.  
  1896. (defun db-setup-ddb-parse-displayspecs (database)
  1897.  
  1898.   ;; Get rid of local variables.
  1899.   (operate-on-local-variables (function delete-region))
  1900.   ;; Get rid of whitespace at end of buffer.
  1901.   (goto-char (point-max))
  1902.   (re-search-backward "[^ \t\n]")
  1903.   (delete-region (match-end 0) (point-max))
  1904.   ;; Get rid of whitespace at ends of lines.
  1905.   (goto-char (dbf-point-min))
  1906.   (while (re-search-forward  "[ \t]+$" nil t)
  1907.     (replace-match ""))
  1908.  
  1909.   (let ((prev-field-end (dbf-point-min))
  1910.     (backslash-placeholder (and (goto-char (dbf-point-min))
  1911.                     (search-forward "\\\\" nil t)
  1912.                     ;; assume this doesn't return nil
  1913.                     (unused-char-in-buffer)))
  1914.     beginning end this-displayspec displayspec-list inter-field-text-list)
  1915.  
  1916.     (if backslash-placeholder
  1917.     (progn
  1918.       (setq backslash-placeholder (char-to-string backslash-placeholder))
  1919.       (goto-char (dbf-point-min))
  1920.       (replace-string "\\\\" backslash-placeholder)))    
  1921.  
  1922.     (setq dbf-default-summary-format nil)
  1923.  
  1924.     (goto-char (dbf-point-min))
  1925.     (while (re-search-forward displayspec-regexp nil t)
  1926.       (db-debug-message "found field %s" (match-string 0))
  1927.       (setq beginning (match-beginning displayspec-regexp-content-beginning)
  1928.         end (or (match-end displayspec-regexp-content-end)
  1929.             (match-end displayspec-regexp-content-end-alt))
  1930.         ;; Call "internal" version of function because match-data is set.
  1931.         ;; nil as first argument means make it from the buffer.
  1932.         this-displayspec (make-displayspec-from-string-internal nil database))
  1933.  
  1934.       ;; Fix up backslash-replacement.  The buffer is fixed up instead of
  1935.       ;; just the inter-field-text-list because of the call to current-column.
  1936.       (if backslash-placeholder
  1937.       (save-excursion
  1938.         (save-restriction
  1939.           (narrow-to-region prev-field-end beginning)
  1940.           (goto-char prev-field-end)
  1941.           (replace-string backslash-placeholder "\\"))))
  1942.  
  1943.       (setq inter-field-text-list
  1944.         (cons (buffer-substring prev-field-end beginning) inter-field-text-list))
  1945.       ;; because the match is about to be deleted, and we just used the old value.
  1946.       (setq prev-field-end beginning)
  1947.  
  1948.       (if (null dbf-default-summary-format)
  1949.       (progn
  1950.         (setq dbf-default-summary-format (save-excursion
  1951.                            (buffer-substring
  1952.                         (progn (beginning-of-line 1)
  1953.                                (point))
  1954.                         (progn (end-of-line 1)
  1955.                                (point)))))
  1956.         ;; This will cause an error if one of the fields on the first
  1957.         ;; line has variable height.  Or it should, at least.  I think.
  1958.         (if (null dbf-summary-format)
  1959.         (setq dbf-summary-format dbf-default-summary-format))))
  1960.  
  1961.  
  1962.       (delete-region beginning end)
  1963.       ;; (displayspec-set-location this-displayspec (point-marker))
  1964.  
  1965.       (if (eq t (displayspec-indent this-displayspec))
  1966.       (displayspec-set-indent this-displayspec (current-column)))
  1967.  
  1968.       (setq displayspec-list
  1969.         (cons this-displayspec displayspec-list))
  1970.  
  1971.       ;; ;; This isn't really necessary since when the user sees it, it will
  1972.       ;; ;; be filled with real data (or this will have been taken care of).
  1973.       ;; (if (displayspec-min-width this-displayspec)
  1974.       ;;     (insert (make-string (displayspec-min-width this-displayspec) ? )))
  1975.       )
  1976.     ;; Fix up backslash-replacement for the post-last text.
  1977.     (if backslash-placeholder
  1978.     (save-excursion
  1979.       (save-restriction
  1980.         (narrow-to-region prev-field-end (point-max))
  1981.         (goto-char prev-field-end)
  1982.         (replace-string backslash-placeholder "\\"))))
  1983.     
  1984.     (setq inter-field-text-list
  1985.       (cons (buffer-substring prev-field-end (point-max)) inter-field-text-list))
  1986.  
  1987.     (db-debug-message "db-setup-ddb:  displayspec-list = %s" displayspec-list)
  1988.  
  1989.     (setq dbf-inter-field-text (vconcat (nreverse inter-field-text-list))
  1990.       dbf-displayspecs (vconcat (nreverse displayspec-list))
  1991.       dbf-displayspecs-length (length dbf-displayspecs)
  1992.       dbf-fields-displayed (make-vector dbf-displayspecs-length nil)
  1993.       dbf-field-search-defaults (make-vector (1+ dbf-displayspecs-length) nil))
  1994.     )
  1995.  
  1996.   ;; initialize more local variables
  1997.   (setq dbf-recordindex-displayspecno-vector
  1998.     (make-vector (database-no-of-fields database) nil))
  1999.   (let ((fsno 0))
  2000.     (while (< fsno dbf-displayspecs-length)
  2001.       (aset dbf-recordindex-displayspecno-vector
  2002.         (displayspec-record-index (aref dbf-displayspecs fsno))
  2003.         fsno)
  2004.       (setq fsno (1+ fsno))))
  2005.  
  2006.   (db-debug-message "db-setup-ddb:  dbf-displayspecs = %s" dbf-displayspecs)
  2007.   (db-debug-message "db-setup-ddb: dbf-summary-format = %s" dbf-summary-format)
  2008.  
  2009.   (dbf-set-summary-format dbf-summary-format)
  2010.  
  2011.   ;; Is this necessary?
  2012.   (set-buffer-modified-p nil))
  2013.  
  2014. ;; (defun undouble-backslashes (string)
  2015. ;;   "Return a copy of STRING, replacing doubled backslashes by single ones."
  2016. ;;   (string-substitute-substring-general-case "\\\\" "\\\\\\\\" string))
  2017.  
  2018. ;; Should use dbf-make-format-spec and dbf-install-format-spec, not
  2019. ;; db-setup-data-display-buffer.  The user knows to use dbf-always around
  2020. ;; anything he wants set here.
  2021. ;; Actually, now that I have copy-buffer-local-variables, it can be much
  2022. ;; simpler and more foolproof.
  2023.  
  2024. (defun db-additional-data-display-buffer ()
  2025.   "Create another data display buffer in which to view this database."
  2026.   (interactive)
  2027.   (dbf-process-current-record-maybe t)
  2028.   (let* ((orig-buffer (current-buffer))
  2029.      (database dbc-database)
  2030.      ; (format-spec (dbf-make-format-spec))
  2031.      (data-display-buffer (db-make-data-display-buffer database nil))
  2032.      ; (af-names dbf-alternate-format-names)
  2033.      ; (af-files dbf-alternate-format-files)
  2034.      )
  2035.     (database-set-data-display-buffers database
  2036.        (cons data-display-buffer (database-data-display-buffers database)))
  2037.     (switch-to-buffer-other-window data-display-buffer)
  2038.  
  2039.     (copy-buffer-local-variables orig-buffer)
  2040.     ;; Here are the trampled-on variables that I really cared about:
  2041.     (setq dbf-this-record (make-record dbc-database))
  2042.     (db-emergency-restore-format t)
  2043.  
  2044.     ; (dbf-install-format-spec format-spec)
  2045.     ; (setq dbf-alternate-format-names af-names
  2046.     ;       dbf-alternate-format-files af-files)
  2047.     ; (db-alternate-format format-name format-file)
  2048.     ; ;; This is of highly questionable taste.
  2049.     ; (db-first-record)
  2050.     ))
  2051.  
  2052.  
  2053. (defun db-alternate-format (&optional format-name filename)
  2054.   "Select and use an alternate display format to view the database.
  2055. If neither FORMAT-NAME nor FILENAME is specified (as is the case when this
  2056. is called interactively), the user is prompted for them.  In Emacs Lisp
  2057. code, if `dbf-alternate-format-names' has been been set, usually only one of
  2058. the arguments is specified.  If both are specified, then FORMAT-NAME
  2059. becomes a name for the format FILENAME specifies; if FORMAT-NAME is already
  2060. associated with a different format file, an error is signalled.
  2061.  
  2062. If the current format is unnamed, the user is prompted for a name
  2063. to give it, so that it can be conveniently restored if need be.  This
  2064. behavior is suppressed, and the record is not displayed, if the function is
  2065. not being called interactively.
  2066.  
  2067. Selecting the current format does not cause any work to be done.
  2068.  
  2069. Some databases automatically set the format of the record being displayed,
  2070. usually by setting `dbf-before-display-record-function' to a function that
  2071. overrides the format in effect when a record is about to be displayed.
  2072. This may cause this function to appear not to be doing any work.  In
  2073. actuality the format is being set, then reset."
  2074.   (interactive)
  2075.  
  2076.   (if (not (and format-name
  2077.         (equal format-name dbf-format-name)))
  2078.       ;; We're not already in the requested format
  2079.       (progn
  2080.     (db-view-mode)
  2081.  
  2082.     ;; If neither format-name nor filename is specified,
  2083.     ;; as the user for one of them.
  2084.     (if (not (or format-name filename))
  2085.         (progn
  2086.           (setq format-name
  2087.             (completing-read "Use which format? (? for options, RET to specify a file) "
  2088.                      ;; This is expensive.  Can't be helped.
  2089.                      ;; The "" is getting pushed to the
  2090.                      ;; beginning of the alphabetical list.
  2091.                      ;; I should fix that but don't know how.
  2092.                      (cons '("") dbf-alternate-format-names)
  2093.                      (function (lambda (assoc-elt)
  2094.                          (stringp (car assoc-elt))))
  2095.                      t))
  2096.           (if (equal "" format-name)
  2097.           (progn
  2098.             (setq format-name nil
  2099.               filename (read-file-name "File for new format: "
  2100.                            nil nil t))))))
  2101.  
  2102.     ;; Either format-name or filename (or possibly both, if not called
  2103.     ;; interactively) is set.
  2104.     (if filename
  2105.         (setq filename (locate-format-file filename)))
  2106.     (if format-name
  2107.         (let ((format-spec (cdr (assoc format-name dbf-alternate-format-names))))
  2108.           (if format-spec
  2109.           ;; successful format-name
  2110.           (let ((fs-filename (format-spec-format-file format-spec)))
  2111.             (if filename
  2112.             (if (and fs-filename
  2113.                  ;; This test is required for interactive
  2114.                  ;; uses of db-alternate-format.
  2115.                  (not (same-file-p filename fs-filename)))
  2116.                 (error "Format name %s is associated with %s, not %s."
  2117.                    format-name fs-filename filename))
  2118.               (setq filename (locate-format-file fs-filename))))
  2119.         ;; unsuccessful format-name
  2120.         (if filename
  2121.             (setq dbf-alternate-format-names
  2122.               (cons (cons format-name filename)
  2123.                 dbf-alternate-format-names))
  2124.           ;; no filename, failed format-name
  2125.           (error "`%s' is not the name of a format.")))))
  2126.     ;; Filename is now set.
  2127.  
  2128.     ;; First save away current format.  No need to do anything with filename.
  2129.     (if (and (interactive-p)
  2130.          (not dbf-format-name)
  2131.          (y-or-n-p "Would you like to give the current format a name? "))
  2132.         (setq dbf-format-name (read-string "Name for current format: ")))
  2133.     (if dbf-format-name
  2134.         (let ((old-fmtname-assoc (assoc dbf-format-name
  2135.                         dbf-alternate-format-names)))
  2136.           (if old-fmtname-assoc
  2137.           (setcdr old-fmtname-assoc (dbf-make-format-spec))
  2138.         (setq dbf-alternate-format-names
  2139.               (cons (cons dbf-format-name (dbf-make-format-spec))
  2140.                 dbf-alternate-format-names)))))
  2141.  
  2142.     ;; Now install the new format.
  2143.     (setq dbf-format-name format-name
  2144.           dbf-format-file filename)
  2145.     (let ((new-format-spec
  2146.            (cdr (assoc dbf-format-file dbf-alternate-format-files))))
  2147.       (if new-format-spec
  2148.           (progn
  2149.         (dbf-install-format-file-spec new-format-spec)
  2150.         (dbf-install-format-spec
  2151.          (cdr (assoc (or dbf-format-name (intern dbf-format-file))
  2152.                  dbf-alternate-format-names))))
  2153.         ;; We didn't find dbf-format-file in dbf-alternate-format-files; we
  2154.         ;; probably didn't find more than just a filename at dbf-format-name
  2155.         ;; in dbf-alternate-format-names either.
  2156.         ;; This let is for the benefit of the new format file.
  2157.         (let ((database dbc-database)
  2158.           (buffer-read-only nil))
  2159.           (db-message "Reading format from %s." dbf-format-file)
  2160.           (buffer-disable-undo (current-buffer))
  2161.           (erase-buffer)
  2162.           (insert-file dbf-format-file)
  2163.          
  2164.           (really-hack-local-variables)
  2165.          
  2166.           (db-setup-ddb-parse-displayspecs dbc-database)
  2167.          
  2168.           ;; Save away the file-invariant stuff.
  2169.           (setq dbf-alternate-format-files
  2170.             (cons (cons dbf-format-file (dbf-make-format-file-spec))
  2171.               dbf-alternate-format-files))
  2172.           ;; Install the defaults under a symbol associated with the format
  2173.           ;; file (so it's not user-accessible).
  2174.           (let ((dbf-summary-format dbf-default-summary-format)
  2175.             (dbf-summary-function (if (equal
  2176.                            dbf-summary-format
  2177.                            dbf-default-summary-format)
  2178.                           dbf-summary-function)))
  2179.         (setq dbf-alternate-format-names
  2180.               (cons (cons (intern dbf-format-file) (dbf-make-format-spec))
  2181.                 dbf-alternate-format-names)))
  2182.           (erase-buffer))))
  2183.  
  2184.     (if (interactive-p)
  2185.         (display-record (dbf-displayed-record) t)))))
  2186.  
  2187.  
  2188. (defun db-emergency-restore-format (&optional recompute)
  2189.   "Replace a format with a fresh one; use this if the format gets munged.
  2190. Changes made to the current field since last moving onto it may be lost.
  2191. If optional prefix arg RECOMPUTE is non-nil, `display-record' recomputes
  2192. the displayed text as well."
  2193.   (interactive "P")
  2194.  
  2195.   ;; (db-setup-data-display-buffer dbf-format-file dbc-database (current-buffer))
  2196.  
  2197.   (display-record (dbf-displayed-record) recompute)
  2198.  
  2199.   (if dbf-this-field-index
  2200.       (let ((this-field-index dbf-this-field-index))
  2201.     (dbf-set-this-field-modified-p nil)
  2202.     (db-move-to-field-exact this-field-index)
  2203.     )))
  2204.  
  2205. ;; This should be somewhere in a set of functions that the user is told about.
  2206.  
  2207. ;; Does this get run in the proper buffer if it appears in the database or
  2208. ;; auxiliary file?  No, but it shouldn't be called in such buffers; it's a
  2209. ;; format function, for goodness sake.
  2210.  
  2211. ;; Calling this function causes db-make-summary-maker to be called at the
  2212. ;; appropriate time.  This is usually right away, but if the database
  2213. ;; information hasn't been read (ie, a call to this appears in the format
  2214. ;; or auxiliary file), it is after the database fieldnames are known.
  2215.  
  2216. (defun dbf-set-summary-format (summary-format)
  2217.   "Specify the format used in the Database Summary buffer.
  2218. Argument SUMMARY-FORMAT is a string containing display specifications.
  2219. Call this in the data display buffer, or in a format file or auxiliary file."
  2220.   (interactive "sSummary format: ")
  2221.   (if (= ?\n (elt summary-format (1- (length summary-format))))
  2222.       (setq summary-format
  2223.         (substring summary-format 0 (1- (length summary-format)))))
  2224.   (setq dbf-summary-format summary-format)
  2225.   (dbf-set-summary-out-of-date-p)
  2226.   (setq dbf-summary-recompute-all-p t)
  2227.   ;; If the alist isn't yet set, then we're still setting up, and this will
  2228.   ;; be called later on; do nothing for now.
  2229.   (if (database-fieldname-alist dbc-database)
  2230.       (dbf-make-summary-maker summary-format dbc-database)))
  2231.  
  2232. (defmacro dbf-always (&rest body)
  2233.   "Execute BODY, and place its forms in `dbf-always-forms'.
  2234. They will be executed each time that this format replaces another."
  2235.   (` (progn
  2236.        (setq dbf-always-forms (nconc dbf-always-forms (, body)))
  2237.        (,@ body))))
  2238. (put 'dbf-always 'edebug-form-spec '(&rest form))
  2239.  
  2240.  
  2241. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2242. ;;; Display data in a format
  2243. ;;;
  2244.  
  2245. ;; Will it be more efficient to erase the buffer and fill it again or to
  2246. ;; find the fields and replace them?
  2247.  
  2248. ;; Why would I want this to take a record as argument instead of using
  2249. ;; dbf-displayed-record?
  2250. ;; Joe Wells has used this feature, so don't remove it.
  2251.  
  2252. (defun display-record (record &optional recompute fieldno-limit)
  2253.   "Display RECORD.  If optional arg RECOMPUTE is non-nil, the display
  2254. representations will be computed first; RECOMPUTE is typically non-nil only
  2255. the first time a record is shown.  If optional third arg FIELDNO-LIMIT is
  2256. non-nil, only fieldnumbers strictly less than it will be displayed."
  2257.   (let ((field-index 0)
  2258.     displayspec
  2259.     printed-rep
  2260.     (buffer-read-only nil)
  2261.      (is-displayed-record-p (eq record (dbf-displayed-record)))
  2262.     ;; If the user quits in this middle of this operation, EDB becomes
  2263.     ;; very confused.  Inhibitting quitting is dangerous, though, so do
  2264.     ;; it only if db-debug-p is nil.
  2265.      (inhibit-quit (not db-debug-p))
  2266.     ext-start
  2267.     )
  2268.     ;; This must be called with is-displayed-record bound.
  2269.     (funcall-maybe dbf-before-display-record-function record)
  2270.     ;; Allow dbf-before-display-record-function to do
  2271.     ;; dbf-set-this-record-modified-p if it wants to.
  2272.     (if is-displayed-record-p
  2273.      (setq record (dbf-displayed-record)))
  2274.     ;; Why is this here?  I guess it can't hurt.
  2275.     (dbc-update-database-modified-p)
  2276.     (buffer-disable-undo (current-buffer))
  2277.     (if db-fontification
  2278.     (map-extents (function (lambda (x y) (delete-extent x)))
  2279.              (current-buffer) (point-min) (point-max) nil))
  2280.     (erase-buffer)
  2281.     (while (< field-index dbf-displayspecs-length)
  2282.       ;; (db-debug-message "display-record:  field %s" field-index)
  2283.       (setq displayspec (aref dbf-displayspecs field-index))
  2284.       (setq ext-start (point))
  2285.       (db-old-insert (aref dbf-inter-field-text field-index))
  2286.       (if db-fontification
  2287.       (db-fontify ext-start (point)))
  2288.       (if recompute
  2289.       (aset dbf-fields-displayed field-index
  2290.         (if (and fieldno-limit
  2291.              (>= field-index fieldno-limit))
  2292.             ;; Should deal with min-height and min-bytes, too.
  2293.             ;; Probably want a function displayspec->empty-printed-rep.
  2294.             (make-string (or (displayspec-min-width displayspec) 0) ? )
  2295.           ;; Could use displayspec->displayed-rep, but it is mainly for
  2296.           ;; updating fields that already exist.
  2297.           (progn
  2298.             (setq printed-rep
  2299.               (displayspec->printed-rep displayspec record))
  2300.             (string-substitute-substring-general-case
  2301.              (concat "\n" (make-string (current-column) 32))
  2302.              "\n"
  2303.              printed-rep)))))
  2304.       ;; Does (dbf-this-field-indent) work at this point?
  2305.       ;; If not, db-insert-string won't.  And I suspect it won't.
  2306.       (db-old-insert (aref dbf-fields-displayed field-index))
  2307.       (setq field-index (1+ field-index)))
  2308.     (setq ext-start (point))
  2309.     (db-old-insert (aref dbf-inter-field-text field-index))
  2310.     (if db-fontification
  2311.     (db-fontify ext-start (point)))
  2312.     ;; Why?  Shouldn't caller be worrying about this?
  2313.     (dbf-set-this-field-modified-p nil)
  2314.     ;; This place is as good as any for leaving the cursor by default.
  2315.     ;; In fact, if dbf-this-field-index is nil, I think I assume the
  2316.     ;; cursor is at point-min.
  2317.     (goto-char (dbf-point-min))
  2318.     (buffer-enable-undo (current-buffer))
  2319.     ;; If the user tried to quit out while this was happening, ignore it.
  2320.     (setq quit-flag nil)
  2321.     ))
  2322.  
  2323. ;; ;; It would probably behoove me to inline the work instead of calling
  2324. ;; ;; dbf-next-field, dbf-set-this-field-text, etc.
  2325. ;; ;; But I would rather just rewrite the whole buffer than parse it cleverly.
  2326. ;; 
  2327. ;; (defun display-record-2 (record &optional fieldno-limit)
  2328. ;;   "Display RECORD.  If optional arg FIELDNO-LIMIT is non-nil, only
  2329. ;; fieldnumbers strictly less than it will be displayed."
  2330. ;;   (let ((field-index 0)
  2331. ;;     displayspec
  2332. ;;     (buffer-read-only nil))
  2333. ;;     (while (< field-index dbf-displayspecs-length)
  2334. ;;       ;; (db-debug-message "display-record-2:  field %s" field-index)
  2335. ;;       (setq displayspec (aref dbf-displayspecs field-index))
  2336. ;;       ;; Unfortunately this does a process-field.
  2337. ;;       (db-next-field 1)
  2338. ;;       (dbf-set-this-field-text
  2339. ;;        (if (and fieldno-limit
  2340. ;;         (>= field-index fieldno-limit))
  2341. ;;        (make-string (or (displayspec-min-width displayspec) 0) ? )
  2342. ;;      (displayspec->printed-rep displayspec record)))
  2343. ;;       (setq field-index (1+ field-index)))
  2344. ;;     (dbf-set-this-field-modified-p nil)
  2345. ;;     ;; This place is as good as any for leaving the cursor by default.
  2346. ;;     ;; In fact, if dbf-this-field-index is non-nil, I think I assume the
  2347. ;;     ;; cursor is at point-min.
  2348. ;;     (goto-char (dbf-point-min))
  2349. ;;     ))
  2350.  
  2351.  
  2352. ;; The goal:  abstract the heck out of this.
  2353. ;; The reason:  so that make-summary-printer can use only parts of it,
  2354. ;; preprocessing when (say) it knows the value of actual->display,
  2355. ;; min-width, and max-width.
  2356. ;; Do it later.
  2357.  
  2358. (defun displayspec->printed-rep (displayspec record)
  2359.   (let* ((record-index (displayspec-record-index displayspec))
  2360.      (display-rep (actual->display-call
  2361.                (displayspec-actual->display displayspec)
  2362.                (aref record record-index)
  2363.                record
  2364.                record-index)))
  2365.     ;; (db-debug-message "displayspec->p-r:  display-rep = `%s'" display-rep)
  2366.    
  2367.     (let ((display-rep-height (1+ (count-array ?\n display-rep)))
  2368.       (min-height (displayspec-min-height displayspec))
  2369.       (max-height (displayspec-max-height displayspec)))
  2370.       (setq display-rep
  2371.         (cond ((and min-height (< display-rep-height min-height))
  2372.            ;; too short
  2373.            (concat display-rep
  2374.                (make-string (- min-height display-rep-height) ?\n)))
  2375.           ((and max-height (> display-rep-height max-height))
  2376.            ;; too tall
  2377.            (substring display-rep 0
  2378.                   (find-char-from-end ?\n display-rep
  2379.                           (- display-rep-height min-height))))
  2380.           (t
  2381.            ;; an acceptable height
  2382.            display-rep))))
  2383.    
  2384.     ;; These conditions are much too simplistic; they only work for one-line
  2385.     ;; representations.
  2386.     (let ((display-rep-length (length display-rep))
  2387.       (min-width (displayspec-min-width displayspec))
  2388.       (max-width (displayspec-max-width displayspec)))
  2389.       (cond ((and min-width (< display-rep-length min-width))
  2390.          ;; too short
  2391.          (let ((padding-action (displayspec-padding-action displayspec)))
  2392.            (if (functionp padding-action)
  2393.            (funcall padding-action
  2394.                 min-width
  2395.                 display-rep
  2396.                 display-rep-length)
  2397.          ;; if padding-action is not a function, it's nil or a cons.
  2398.          (let ((pad-string (make-string (max 0 (- min-width
  2399.                               display-rep-length))
  2400.                         (or (car padding-action) ? ))))
  2401.            (if (cdr padding-action)
  2402.                (concat pad-string display-rep)
  2403.              (concat display-rep pad-string))))))
  2404.         ((and max-width (> display-rep-length max-width))
  2405.          ;; too long
  2406.          (let ((trunc-action (displayspec-truncation-display-action displayspec)))
  2407.            (cond ((eq 'widen trunc-action)
  2408.               display-rep)
  2409.              ((eq 'error trunc-action)
  2410.               (error "Value %s is too wide; should be between %s and %s characters."
  2411.                  display-rep min-width max-width))
  2412.              ((null trunc-action)
  2413.               (substring display-rep 0 max-width))
  2414.              ((integerp trunc-action)
  2415.               ;; trunc-action is a character
  2416.               (concat (substring display-rep 0 (1- max-width))
  2417.                   trunc-action))
  2418.              (t
  2419.               (error "Unrecognized trunc-action %s." trunc-action)))))
  2420.         (t
  2421.          ;; an acceptable length
  2422.          display-rep)))))
  2423.  
  2424. ;; Like displayspec->printed-rep, but more so
  2425. (defun displayspec->displayed-rep (displayspec record)
  2426.   (let ((pr (displayspec->printed-rep dbf-this-displayspec
  2427.                       dbf-this-record)))
  2428.     (if (displayspec-indent displayspec)
  2429.     (if (numberp (displayspec-indent displayspec))
  2430.         (string-substitute-substring-general-case
  2431.          (concat "\n" (make-string (dbf-this-field-indent) 32))
  2432.          "\n"
  2433.          pr)
  2434.       ;; Why can't I use (dbf-this-field-indent) even here??
  2435.       (if (find-char ?\n pr)
  2436.           (error "Don't know how much to indent.")
  2437.         pr))
  2438.       pr)))
  2439.  
  2440.  
  2441. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2442. ;;; Etc.
  2443. ;;;
  2444.  
  2445.  
  2446. ;; This is mostly useful because it gives help for database mode.
  2447.  
  2448. ;; It would be nice to have, for the sake of this documentation string,
  2449. ;; three more keymaps, one each for the bindings unique to edit map, unique
  2450. ;; to the view map, and common to both.  But that would be wasteful, I
  2451. ;; suppose.
  2452.  
  2453. (defun database-mode ()
  2454.   "A mode for viewing and editing formatted data; a database front end.
  2455. In Database Edit Mode, fields of the database may be changed.
  2456. In Database View Mode, keystrokes are bound to database commands.
  2457. Typically, if point is on a field, the buffer is in Edit Mode;
  2458. if point is at the beginning of the buffer, the buffer is in View Mode.
  2459. See the mode line to find out which mode the buffer is in.
  2460.  
  2461. View mode key bindings:
  2462.  
  2463. \\{database-view-mode-map}
  2464.  
  2465. Edit mode key bindings:
  2466.  
  2467. \\{database-edit-mode-map}"
  2468.  
  2469.   (setq major-mode 'database-mode)
  2470.   (setq mode-name "Database")
  2471.  
  2472.   (setq buffer-file-name nil)
  2473.   (auto-save-mode 0)
  2474.  
  2475.   (setq mode-line-format
  2476.     '("-"
  2477.       (dbc-database-modified-p "*" "-")
  2478.       (dbf-this-record-modified-p "*" "-")
  2479.       ;; I don't particularly want the % for read-only.
  2480.       ;; ((buffer-modified-p) "*" "-")
  2481.       "%*"
  2482.       "-Database: %17b   %[("
  2483.       dbf-minor-mode-name
  2484.       minor-mode-alist
  2485.       " "
  2486.       dbc-index-fraction
  2487.       ")%]"
  2488.       "---"
  2489.       (-3 . "%p")
  2490.       "-%-"))
  2491.  
  2492.   (db-view-mode)
  2493.  
  2494.   )
  2495.  
  2496. ;;   "T if this buffer is a database data display buffer."
  2497. (defun db-data-display-buffer-p ()
  2498.   (eq major-mode 'database-mode))
  2499.  
  2500. (proclaim-inline db-data-display-buffer-p)
  2501.  
  2502. ;;   "T if this buffer is a database data display buffer or database summary buffer."
  2503. (defun database-buffer-p ()
  2504.   (or (db-data-display-buffer-p)
  2505.       (db-summary-buffer-p)))
  2506. (proclaim-inline database-buffer-p)
  2507.  
  2508. ;;; db-format.el ends here
  2509.