home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / packages / edb / db-file-io.el < prev    next >
Encoding:
Text File  |  1993-06-13  |  79.9 KB  |  2,050 lines
  1. ;;; db-file-io.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. ;; Read and write database files.
  11.  
  12. ;;; Code:
  13.  
  14.  
  15. ;;; Variables used dynamically; avoid compiler messages about free variables.
  16. (defvar database)
  17.  
  18.  
  19. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  20. ;;; DB variables
  21. ;;;
  22.  
  23. ;; This won't be such a concern once every field is explicitly specified
  24. ;; when the database is written out.  But until then, should it be
  25. ;; buffer-local?  (It's not in the data display buffer that I care so much
  26. ;; but in the read-database buffer.)
  27.  
  28. (deflocalvar db-default-field-type 'string
  29.   "The type to use for record fields whose type is not explicitly specified.")
  30.  
  31. (defvar db-format-file-path nil
  32.   "List of directories (strings) to search, in order, for format files not
  33. found in the directory with their associated databases.")
  34.  
  35. (defvar db-aux-file-path nil
  36.   "List of directories (strings) to search, in order, for auxiliary files not
  37. found in the directory with their associated databases.")
  38.  
  39.  
  40. ;; T if there has been an error while reading or writing the database, else nil.
  41. ;; This is set on file read, but the value is not currently used.
  42. (defvar db-io-error-p nil)
  43.  
  44. (defvar db-before-read-hooks nil
  45.   "Function or list of functions run immediately before a database is first read
  46. but after all local variables are set.
  47. The hooks are run in the data display buffer with variable  database  bound.
  48. Variable  db-buffer  is bound to a buffer containing the database file.
  49.  
  50. This is a global variable.  If you set it to be specific to a particular
  51. database \(for instance, in the format or auxiliary file), then consider
  52. having its last action be to reset the variable to nil.")
  53.  
  54. (defvar db-after-read-hooks nil
  55.   "Function or list of functions run after a database is completely read.
  56. The hooks are run in the data display buffer with variable  database  bound.
  57. For databases with nonregular formats, you might put a call to
  58. `database-stored->actual' here, for instance.
  59.  
  60. This is a global variable.  If you set it to be specific to a particular
  61. database \(for instance, in the format or auxiliary file), then consider
  62. having its last action be to reset the variable to nil.")
  63.  
  64. (defvar db-format-file-suffixes '(".dbf" ".fmt" "f")
  65.   "List of format file suffixes; the basename is that of the database file.
  66. The suffixes are tried in order; the default is \(\".dbf\" \".fmt\" \"f\").
  67. The . that may precede the extension must be specified explicitly.")
  68.  
  69. (defvar db-aux-file-suffixes '(".dba" ".aux" "a")
  70.   "List of auxiliary file suffixes; the basename is that of the database file.
  71. The suffixes are tried in order; the default is \(\".dba\" \".aux\" \"a\").
  72. The . that may precede the extension must be specified explicitly.")
  73.  
  74.  
  75. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  76. ;;; Read a database file
  77. ;;;
  78.  
  79.  
  80. ;; This assumes that the database doesn't exist.
  81. ;; If the database exists, call read-database-file-helper instead to
  82. ;; refresh it (which requires getting the database file into a buffer first).
  83. ;; "Return the database.  The data display buffer will be the first element of
  84. ;; its data-display-buffers slot.
  85. ;; 
  86. ;; Optional arg FORMAT-FILE, a filename, specifies the format file which
  87. ;; describes how database records are displayed.  If it is nil, the default
  88. ;; \(in the default-format-file slot of the database\) will be used, or one
  89. ;; returned by `db-file->format-file' will be used, or the user will be
  90. ;; prompted for one.
  91. ;; 
  92. ;; If optional prefix arg CONFIRM is non-nil, then no default will be used
  93. ;; without confirmation from the user."
  94. (defun read-database-file (db-file &optional format-file confirm)
  95.   (interactive "fDatabase file: \nP")
  96.   (setq db-io-error-p nil)
  97.   (let ((db-buffer (generate-new-buffer "read-database-file"))
  98.     data-display-buffer
  99.     database)
  100.  
  101.     ;; (make-database :file db-file)
  102.     ;; (hack-local-variables t)
  103.  
  104.     (set-buffer db-buffer)
  105.     (if (file-exists-p db-file)
  106.     (insert-file-contents db-file nil)
  107.       (message "New database file."))
  108.  
  109.     (setq database (read-database-internal-file-layout-maybe))
  110.     (database-set-file database db-file)
  111.     (database-set-modifiable-p database (file-writable-p db-file))
  112.  
  113.     (db-debug-message "read-database-file:  database = %s" database)
  114.  
  115.     ;; This is done in db-setup-data-display-buffer.
  116.     ;; (read-db-aux-file database)
  117.     ;; (db-set-fieldname-vars database)
  118.  
  119.     ;; when could format-file be t?
  120.     ;; (if (eq format-file t)
  121.     ;;     (setq format-file nil))
  122.  
  123.     (if (or (not format-file)
  124.         confirm)
  125.     ;; We may be calling this because the argument to
  126.     ;; read-database-file wasn't specified.
  127.     (setq format-file (choose-format-file database format-file confirm)))
  128.  
  129.     (setq data-display-buffer
  130.       (db-setup-data-display-buffer format-file database t))
  131.     (database-set-data-display-buffers database
  132.       (cons data-display-buffer (database-data-display-buffers database)))
  133.  
  134.     ;; (db-debug-message "rdf:  recordfieldspecs = %s" (database-recordfieldspecs database))
  135.  
  136.     (in-buffer data-display-buffer
  137.        (run-hooks 'db-before-read-hooks))
  138.  
  139.     ;; Local variables are now set from database, aux, and format files.
  140.     (read-database-file-helper db-buffer database)
  141.  
  142.     (in-buffer data-display-buffer
  143.        (run-hooks 'db-after-read-hooks))
  144.  
  145.     database))
  146.  
  147.  
  148. ;;   "Return a database.
  149. ;; If the buffer contains a database in internal file layout, it is returned.
  150. ;; \(The records are not read from the buffer, only the database structure.\)
  151. ;; Otherwise, an empty database is returned."
  152. (defun read-database-internal-file-layout-maybe ()
  153.   (if (skip-string-forward ";; Database file written by EDB")
  154.       (let ((here (point)))
  155.     (emacs-lisp-mode)
  156.     ;; Update old formats in small increments.
  157.     (if (skip-string-forward "; format 0.1")
  158.         (progn
  159.           (delete-backward-char 1)
  160.           (insert "2")
  161.           (forward-sexp)
  162.           (backward-char 1)
  163.           ;; add locals slot to database
  164.           (insert " nil")
  165.           (goto-char here)))
  166.     (if (skip-string-forward "; format 0.2")
  167.         (progn
  168.           (delete-backward-char 1)
  169.           (insert "3")
  170.           (forward-sexp)
  171.           (backward-char 1)
  172.           (backward-sexp 1)
  173.           (backward-char 1)
  174.           ;; add modified-p slot to database
  175.           (insert " nil")
  176.           (goto-char here)))
  177.     (if (skip-string-forward "; format 0.3")
  178.         (progn
  179.           (delete-backward-char 1)
  180.           (insert "4")
  181.           (down-list 1)
  182.           (forward-sexp 16)
  183.           ;; add internal-file-layout-p slot to database
  184.           (insert " t")
  185.           (forward-sexp 14)
  186.           ;; add modifiable-p slot to database
  187.           (insert " t")
  188.           (goto-char here)))
  189.     ;; Don't forget to change write-database file if the format
  190.     ;; number is updated.
  191.     (if (not (skip-string-forward "; format 0.4"))
  192.         (db-message "I don't know if I can read the database, but I'll try."))
  193.     (read (current-buffer)))
  194.     (make-database)))
  195.  
  196.  
  197. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  198. ;;; Format file
  199. ;;;
  200.  
  201. (defun db-file->format-file (db-file)
  202.   "Return a format file or nil."
  203.   (let* ((subdir (file-name-directory db-file))
  204.      (default-directory (if subdir
  205.                 (expand-file-name subdir)
  206.                   default-directory))
  207.      (default-file (locate-file-with-extensions-on-path
  208.             db-file db-format-file-suffixes db-format-file-path)))
  209.     (if default-file
  210.     (expand-file-name default-file))))
  211.  
  212. ;;   "Return a full pathname for the format file named FILENAME, or err."
  213. (defun locate-format-file (filename)
  214.   ;; The expand-file-name is needed only if the file is in the
  215.   ;; current directory.  Perhaps locate-file-on-path should always
  216.   ;; return a full pathname for the file.
  217.   (let ((checked-filename (locate-file-on-path filename db-format-file-path)))
  218.     (if checked-filename
  219.     (expand-file-name checked-filename)
  220.       (error "I can't find a format file named %s." filename))))
  221.  
  222. ;;   "Return a format file according to DATABASE or FORMAT-FILE-DEFAULT.
  223. ;; Prompt if CONFIRM is set or if we can't get one from DATABASE alone."
  224. (defun choose-format-file (database format-file-default confirm)
  225.   (let* ((db-file (database-file database))
  226.      (default (or format-file-default
  227.               (database-default-format-file database)
  228.               (db-file->format-file db-file))))
  229.     (db-debug-message "db-file = %s, sans extension = %s"
  230.               db-file (filename-sans-extension db-file))
  231.     (if (and default (not confirm))
  232.     (let* ((dir (file-name-directory db-file))
  233.            (default-directory (if dir
  234.                        (expand-file-name dir)
  235.                      default-directory)))
  236.       (locate-format-file default))
  237.       ;; Don't need locate-format-file because MUSTMATCH arg
  238.       ;; to read-file-name is t.
  239.       (expand-file-name
  240.        (read-file-name
  241.     (if default
  242.         (format "Display format for %s: [default %s] "
  243.             (file-name-nondirectory db-file)
  244.             (file-name-nondirectory default))
  245.       (format "Display format for %s: "
  246.           (file-name-nondirectory db-file)))
  247.     (file-name-directory db-file)
  248.     (if default
  249.         (expand-file-name default (file-name-directory db-file)))
  250.     t)))))
  251.  
  252.  
  253. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  254. ;;; Read database file:  helper functions
  255. ;;;
  256.  
  257. ;; The format and the auxiliary file should already be loaded; ie, all
  258. ;; special variables should be set.
  259.  
  260. ;; This is separate because we might want to simply refresh a database from
  261. ;; disk without going through the hoopla of setting variables, etc.
  262. ;;   "DB-BUFFER is a buffer containing the database file; DATABASE is the
  263. ;; database to be read into.
  264. ;; The local variables section of DB-BUFFER is not executed, nor are the
  265. ;; database's auxiliary file read, nor are any database slots filled \(except
  266. ;; for first-link\)."
  267. (defun read-database-file-helper (db-buffer database)
  268.  
  269.   (db-message "Reading database...")
  270.  
  271.   (set-buffer db-buffer)
  272.  
  273.   (if (database-internal-file-layout-p database)
  274.       (let ((record-list (read (current-buffer))))
  275.     (db-message "Linking records...")
  276.     (database-set-links-from-list
  277.      database
  278.      (mapcar (function make-link-from-record)
  279.          record-list)))
  280.     (progn
  281.       (database-io-setup database t)
  282.       (database-delete-pre-and-post database)
  283.      
  284.       (if (database-read-record-from-region database)
  285.       (read-database-file-custom database)
  286.     (read-database-file-delimited database))))
  287.  
  288.   (db-debug-message "read-database-file-helper:  about to kill %s"
  289.             (current-buffer))
  290.   (kill-buffer (current-buffer))
  291.   (setq db-databases
  292.     (cons database db-databases))
  293.   (db-message "Done reading database.  %s records total."
  294.        (database-no-of-records database))
  295.   database)
  296.  
  297.  
  298. (defun database-set-links-from-list (database list-of-links)
  299.  
  300.   ;; Takes a list of links, sets database-first-link to the first one and
  301.   ;; sets link-next and link-prev of each such that all the links are
  302.   ;; arranged in a doubly-linked list in the order of the list.
  303.  
  304.   (database-set-no-of-records database (length list-of-links))
  305.   (db-debug-message "database-set-links-from-list:  length = %s"
  306.             (length list-of-links))
  307.   (let ((prev-link (car list-of-links))
  308.     this-link)
  309.     (database-set-first-link database prev-link)
  310.     (setq list-of-links (cdr list-of-links))
  311.     (while list-of-links
  312.       (setq this-link (car list-of-links))
  313.       (link-two prev-link this-link)
  314.       (setq prev-link this-link)
  315.       (setq list-of-links (cdr list-of-links)))
  316.     (link-two prev-link (database-first-link database))))
  317.  
  318.  
  319. ;; Body should setq this-record.  Body uses dynamic variable database.
  320. (defmacro read-database-file-noninternalformat-macro (condition &rest body)
  321.  
  322.   (` (let* (this-record
  323.         this-link
  324.         last-link
  325.         first-link)
  326.       
  327.        (setq dbc-index 0)
  328.        (while (, condition)
  329.      (setq dbc-index (1+ dbc-index))
  330.     
  331.      ;; This is noisy, and it obscures the warning messages, but
  332.      ;; reading is so slow that it's necessary.
  333.      (if (and db-inform-interval
  334.           (zerop (% dbc-index db-inform-interval)))
  335.          (db-message "Reading database...%d" dbc-index))
  336.     
  337.      (,@ body)
  338.     
  339.      (setq this-link (make-link-from-record this-record))
  340.      (if (not first-link)
  341.          (setq first-link this-link
  342.            last-link this-link))
  343.      (link-two last-link this-link)
  344.      (setq last-link this-link))
  345.       
  346.        (db-debug-message "read-database-file-noninternalformat-macro:  condition satisfied")
  347.       
  348.        (if first-link
  349.        (link-two last-link first-link))
  350.        (database-set-first-link database first-link)
  351.        (database-set-no-of-records database dbc-index))))
  352. (put 'read-database-file-noninternalformat-macro 'lisp-indent-hook 1)
  353. (put 'read-database-file-noninternalformat-macro 'edebug-form-spec '(&rest form))
  354.  
  355. ;; Uses database-read-record-from-region and sepinfo-sepfunc from
  356. ;; database-record-sepinfo.
  357.  
  358. ;; Maybe turn some of the support structure that's used both here and in
  359. ;; read-database-file-delimited-internal (eg linking stuff) into a
  360. ;; macro.
  361.  
  362. (defun read-database-file-custom (database)
  363.   (let ((region->record (database-read-record-from-region database))
  364.     (record-sepinfo (database-record-sepinfo database)))
  365.  
  366.     ;; Check that the sepinfo has enough information.
  367.     (if (sepinfo-sep-regexp record-sepinfo)
  368.     (if (not (sepinfo-sep-regexp-submatch record-sepinfo))
  369.         (error "Need a submatch to go with sep-regexp `%s' of record sepinfo."
  370.            (sepinfo-sep-regexp record-sepinfo)))
  371.       (if (not (sepinfo-sep-function record-sepinfo))
  372.       (let ((sep-string (sepinfo-sep-string record-sepinfo)))
  373.         (if (or (not sep-string)
  374.             (equal "" sep-string))
  375.         (error "You haven't specified a string, regexp, or function in record sepinfo."))
  376.         (sepinfo-set-regexp-and-submatch-from-string
  377.          sepinfo-set-sep-regexp sepinfo-set-sep-regexp-submatch
  378.          record-sepinfo
  379.          (sepinfo-sep-string record-sepinfo) database))))
  380.  
  381.     ;; Merge this into the above, maybe, so I don't have to check twice
  382.     ;; whether we're using sep-function or regexp.
  383.  
  384.     (db-debug-message "read-database-file-custom:  done checking sepinfo.")
  385.  
  386.     (if (sepinfo-sep-function record-sepinfo)
  387.     ;; use sep-function to delimit the records
  388.  
  389.     ;; return a pair of (end-pos . start-pos)
  390.     (let ((delimit-record (sepinfo-sep-function record-sepinfo))
  391.           ;; Read-record-from-region might do insertions or deletions,
  392.           ;; so just remembering the position isn't enough.
  393.           ;; I don't know that this works, though, due to narrowing.
  394.           next-start-marker
  395.           (prev-end-pos 'nil)
  396.           (end-start-pair '(nil)))
  397.       (goto-char (point-min))
  398.       (setq next-start-marker (point-marker))
  399.  
  400.       ;; This assumes that there is at least one record in the file.
  401.       ;; This is a bug.  (Fix it at the beginning of this
  402.       ;; function or in the caller.)
  403.       (read-database-file-noninternalformat-macro
  404.           (marker-position next-start-marker)
  405.        
  406.         (setq end-start-pair (funcall delimit-record prev-end-pos))
  407.         (db-debug-message "read-database-file-custom:  end-start-pair = %s"
  408.                   end-start-pair)
  409.         (narrow-to-region (marker-position next-start-marker)
  410.                   (car end-start-pair))
  411.         ;; Writers of record->region often forget to do this.
  412.         (goto-char (point-min))
  413.         (db-debug-message "read-database-file-custom:  region = %s %s, next-start = %s"
  414.                   (point-min) (point-max) (cdr end-start-pair))
  415.         (setq this-record (funcall region->record))
  416.         ;; not (car end-start-pair) in case buffer was modified
  417.         (setq prev-end-pos (point-max))
  418.         (widen)
  419.         ;; In 18.55, set-marker can only make markers point to the
  420.         ;; accessible portion of the buffer, so do this after widening.
  421.         ;; (This may have changed by 18.59.)
  422.         ;; Don't use just (cdr end-start-pair) because the buffer may
  423.         ;; have been modified.
  424.         (set-marker next-start-marker (and (cdr end-start-pair)
  425.                            (+ (- (cdr end-start-pair)
  426.                              (car end-start-pair))
  427.                           prev-end-pos)))
  428.         (db-debug-message "read-database-file-custom:  next-start-marker = %s"
  429.                   next-start-marker)
  430.         )
  431.      
  432.       )
  433.       ;; use regexp to delimit the records
  434.       (let ((record-sep-regexp (sepinfo-sep-regexp record-sepinfo))
  435.         (record-sep-regexp-submatch (sepinfo-sep-regexp-submatch
  436.                      record-sepinfo))
  437.         (next-start-pos (point-min))
  438.         ;; How many characters to skip before looking for the start
  439.         ;; of the next record.  This is because region->record may
  440.         ;; insert or delete, so we can't use a position, but markers
  441.         ;; get squeezed when narrow-to-region is done.
  442.         sep-length)
  443.     ;; The caller also called database-delete-pre-and-post.
  444.     (goto-char (point-min))
  445.  
  446.     (read-database-file-noninternalformat-macro
  447.         (< next-start-pos (point-max))
  448.      
  449.       (goto-char next-start-pos)
  450.       ;; re-search-forward errs if it fails
  451.       (re-search-forward record-sep-regexp)
  452.       (setq sep-length (- (match-end record-sep-regexp-submatch)
  453.                   (match-beginning record-sep-regexp-submatch)))
  454.       (narrow-to-region next-start-pos
  455.                 (match-beginning record-sep-regexp-submatch))
  456.       (setq this-record (funcall region->record))
  457.       (setq next-start-pos (+ (point-max) sep-length))
  458.       (widen))))))
  459.  
  460.  
  461.  
  462. ;; If there are any regexps set in the spinfos at this point, then we
  463. ;; assume that the programmer specified them explicitly; we assume that if
  464. ;; any substitutions are requested, then the programmer knows that they
  465. ;; won't cause any ambiguities.
  466. (defun read-database-file-delimited (database)
  467.  
  468.   (db-debug-message "read-database-file-delimited:  converting complex->simple")
  469.  
  470.   (goto-char (point-min))
  471.  
  472.   ;; We have now cleared away the pre- and post- garbage.
  473.   (if (or (sepinfo-sep-regexp (database-field-sepinfo database))
  474.       (sepinfo-sep-regexp (database-record-sepinfo database)))
  475.       ;; There are regexps involved, so do no substitution on the separators,
  476.       ;; except that the user has explicitly requrested; then read the database.
  477.       (progn
  478.     (database-perform-substitutions database t)
  479.     (read-database-file-delimited-regexp database))
  480.    
  481.     ;; There are no regexps involved.
  482.     (let* ((fieldsep-string (database-full-fieldsep-string database))
  483.        (recordsep-string (database-full-recordsep-string database))
  484.        confirmation-list)
  485.  
  486.       ;; Convert the database buffer from "complex" to "simple" form.
  487.       (let* ((field-sepinfo (database-field-sepinfo database))
  488.          (pre-first-field-string (sepinfo-pre-first-string field-sepinfo))
  489.          (pre-first-field-regexp (sepinfo-pre-first-regexp field-sepinfo))
  490.          ;; (post-last-field-string (sepinfo-post-last-string field-sepinfo))
  491.          ;; (post-last-field-regexp (sepinfo-post-last-regexp field-sepinfo))
  492.          )
  493.     ;; database-delete-pre-and-post only did the record separators;
  494.     ;; here we do the field separators as well.
  495.     (goto-char (point-min))
  496.     (cond (pre-first-field-regexp
  497.            (if (skip-regexp-forward pre-first-field-regexp)
  498.            (delete-region (point-min) (point))
  499.          (error "Didn't find match for regexp `%s' leading the first field."
  500.             pre-first-field-regexp)))
  501.           (pre-first-field-string
  502.            (if (skip-string-forward pre-first-field-string)
  503.            (delete-region (point-min) (point))
  504.          (error "Didn't find string `%s' leading the first field."
  505.             pre-first-field-string))))
  506.  
  507.     (goto-char (point-max))
  508.     ;; Don't get rid of post-last-field-regexp or post-last-field-string
  509.     ;; because we look for them at the end of every record.
  510.  
  511.     ;; Make sure that record-sepinfo-sep-string appears at the end.
  512.     (if (sepinfo-sep-string (database-record-sepinfo database))
  513.         (if (skip-string-backward
  514.          (sepinfo-sep-string (database-record-sepinfo database)))
  515.         (goto-char (point-max))
  516.           (insert (sepinfo-sep-string (database-record-sepinfo database)))))
  517.     (if pre-first-field-string
  518.         (insert pre-first-field-string)))
  519.  
  520.       ;; We're still inside the big let.
  521.  
  522.       ;; This pre-read confirmation should be optional.  And it should be
  523.       ;; able to deal with regexps.
  524.       ;; When would this test fail?  Won't fieldsep-string and
  525.       ;; recordsep-string always be non-nil when we get here?
  526.       (if (and fieldsep-string recordsep-string)
  527.       (progn
  528.         (db-message "Confirming database format...")
  529.         (setq confirmation-list (database-confirm-fieldsep-and-recordsep
  530.                      fieldsep-string recordsep-string
  531.                      (database-no-of-fields database) nil))
  532.         ;;      (db-debug-message "read-database-file-delimited:  confirmation-list = %s"
  533.         ;;           confirmation-list)
  534.         (if (or (conflist-fieldsep-bad-p confirmation-list)
  535.             (conflist-recordsep-bad-p confirmation-list))
  536.         (progn
  537.           (db-warning "The database file is malformed!")
  538.           (if (conflist-fieldsep-bad-p confirmation-list)
  539.               (db-warning "Extra field separator `%s' found in data."
  540.                   fieldsep-string))
  541.           (if (conflist-recordsep-bad-p confirmation-list)
  542.               (db-warning "Extra record separator `%s' found in data."
  543.                   recordsep-string))
  544.           ;; show the db warning buffer
  545.           (if (yes-or-no-p "Database file is improperly formatted; try to read it anyway? ")
  546.               (db-message "Damaged database being read; expecting approximately %s records."
  547.                    (conflist-no-of-records confirmation-list))
  548.             (progn
  549.               (kill-buffer (current-buffer))
  550.               (error "Aborted attempt to read database."))))
  551.           (db-message "Database looks OK from here; expecting %d records."
  552.               (conflist-no-of-records confirmation-list)))))
  553.    
  554.       ;; This recomputes the full-fieldsep and full-recordsep; oh well.
  555.       ;; It also sets the io-sep variables.
  556.       (database-substitute-for-read database)
  557.    
  558.       (read-database-file-delimited-string database)
  559.       )))
  560.  
  561.  
  562. ;; When we call this, the database is in the following form:
  563. ;; Point at start of first field of first record.
  564. ;; Each field, except last, is ended by actual-fieldsep.
  565. ;; Each record, including last, is ended by actual-recordsep.
  566. ;; End of last recordsep-string = eob.
  567. ;; Field-sep and record-sep must be strings.  (Perhaps permit regexps later.)
  568.  
  569. (defun read-database-file-delimited-string (database)
  570.  
  571.   (db-message "Reading database...")
  572.  
  573.   (goto-char (point-min))
  574.   (let* ((field-sep (database-sub-fieldsep-string database))
  575.      (record-sep (database-sub-recordsep-string database))
  576.      (field-sep-length (length field-sep))
  577.      (record-sep-length (length record-sep))
  578.      (no-of-fields (database-no-of-fields database))
  579.      (max-field-no (1- (database-no-of-fields database)))
  580.      (here (point))
  581.      field-no
  582.      ;; (recordfieldspecs (database-recordfieldspecs database))
  583.      end-of-record-sep
  584.      end-of-record)
  585.  
  586.     (read-database-file-noninternalformat-macro
  587.     (not (eobp))
  588.       ;; This progn is not strictly necessary, but it serves to delimit the
  589.       ;; extent of the body of read-database-file-noninternalformat-macro.
  590.       (progn
  591.     ;; (db-message "read-database-file-delimited-string:  not eobp at %s/%s" (point) (point-max))
  592.     (setq this-record (make-vector no-of-fields nil))
  593.     (if (search-forward record-sep nil t)
  594.         (setq end-of-record-sep (point)
  595.           end-of-record (- (point) record-sep-length))
  596.       (progn
  597.         (db-warning "Didn't find `%s' at end of last field of record %d, and I put it there myself!"
  598.             record-sep dbc-index)
  599.         (setq end-of-record-sep (point-max)
  600.           end-of-record (point-max))))
  601.     (goto-char here)
  602.  
  603.     (setq field-no 0)
  604.     (while (< field-no max-field-no)
  605.      
  606.       ;; I should trap errors here.  Don't check for record-sep in the
  607.       ;; field text, however, because that's too slow.
  608.      
  609.       (if (search-forward field-sep end-of-record t)
  610.           (progn
  611.         (record-set-field-from-index
  612.          this-record field-no
  613.          (buffer-substring here
  614.                    ;; more efficient than (match-beginning 0)
  615.                    (- (point) field-sep-length))
  616.          nil)
  617.         (setq here (point))
  618.         (setq field-no (1+ field-no)))
  619.         (progn
  620.           (db-warning "Hit the end of the record after %d fields of record %d (didn't find field-sep `%s')"
  621.               field-no dbc-index field-sep)
  622.           (record-set-field-from-index
  623.            this-record field-no
  624.            (buffer-substring here end-of-record)
  625.            nil)
  626.           (setq here end-of-record)
  627.           (setq field-no (1+ field-no))
  628.           (while (<= field-no max-field-no)
  629.         (record-set-field-from-index
  630.          this-record field-no
  631.          (recordfieldspec-default-value
  632.           (database-recordfieldspec database field-no))
  633.          nil)
  634.         (setq field-no (1+ field-no))))))
  635.     ;; If there weren't too few fields, set the last one (else it's already set).
  636.     (if (= field-no max-field-no)
  637.         (progn
  638.           (if (search-forward field-sep end-of-record t)
  639.           (progn
  640.             (db-warning "Extra fields in record %d packed into the last field; beware when writing."
  641.                 dbc-index)
  642.             (setq db-io-error-p t)))
  643.           (record-set-field-from-index this-record max-field-no
  644.                        (buffer-substring here end-of-record)
  645.                        nil)))
  646.     (goto-char end-of-record-sep)
  647.     (setq here (point))))
  648.      
  649.  
  650.     ;; The caller takes care of this.
  651.     ;; (kill-buffer (current-buffer))
  652.  
  653.     ;; Convert from stored to actual format.  It's possible that it will be
  654.     ;; cheaper to do something above without even creating the
  655.     ;; about-to-be-trashed string (ie, operate directly on the buffer).
  656.     ;; But that sounds like too much work by far.
  657.     ;; (db-debug-message "read-database-file-delimited-string:  converting")
  658.  
  659.     (database-stored->actual database)
  660.  
  661.     ;; (db-debug-message "read-database-file-delimited-string:  returning")
  662.  
  663.     ;; This function is called for side-effect, but return the database anyway.
  664.     database))
  665.  
  666.  
  667. ;; I should clearly merge this with ...-delimited-string eventually.
  668.  
  669. ;; For now I don't deal with pre- and post- on the field sepinfo.  I will soon.
  670. ;; (Actually, I do deal with post-, but don't tell.)
  671. (defun read-database-file-delimited-regexp (database)
  672.  
  673.   (db-message "Reading database...")
  674.  
  675.   (goto-char (point-min))
  676.  
  677.   ;; I have a feeling of deja vu.  Have I don't this elsewhere before?
  678.   ;; Maybe in read-sepinfo-items.
  679.   (let* ((field-sepinfo (database-field-sepinfo database))
  680.      (record-sepinfo (database-record-sepinfo database))
  681.      (field-regexp (or (sepinfo-sep-regexp field-sepinfo)
  682.                (regexp-quote (sepinfo-sep-string
  683.                       (database-field-sepinfo database)))))
  684.     (field-regexp-submatch (or (sepinfo-sep-regexp-submatch field-sepinfo)
  685.                    0))
  686.     (record-regexp (or (sepinfo-sep-regexp record-sepinfo)
  687.                (regexp-quote (sepinfo-sep-string record-sepinfo))))
  688.     (record-regexp-submatch (or (sepinfo-sep-regexp-submatch record-sepinfo)
  689.                     0))
  690.  
  691.     ;; I can't fold these in to the record-regexp because they may have
  692.     ;; submatches of their own.
  693.     (pre-first-field-string (sepinfo-pre-first-string field-sepinfo))
  694.     (pre-first-field-regexp (or (sepinfo-pre-first-regexp field-sepinfo)
  695.                     (and pre-first-field-string
  696.                      (regexp-quote pre-first-field-string))))
  697.     (pre-first-field-regexp-submatch (or (sepinfo-pre-first-regexp-submatch
  698.                           field-sepinfo)
  699.                          0))
  700.     (post-last-field-string (sepinfo-post-last-string field-sepinfo))
  701.     (post-last-field-regexp (or (sepinfo-post-last-regexp field-sepinfo)
  702.                     (and post-last-field-string
  703.                      (regexp-quote post-last-field-string))))
  704.     (post-last-field-regexp-submatch (or (sepinfo-post-last-regexp-submatch
  705.                           field-sepinfo)
  706.                          0))
  707.  
  708.     (no-of-fields (database-no-of-fields database))
  709.     (max-field-no (1- (database-no-of-fields database)))
  710.     (here (point))
  711.     field-no
  712.     ;; (recordfieldspecs (database-recordfieldspecs database))
  713.     end-of-record-regexp
  714.     end-of-record)
  715.  
  716.     (read-database-file-noninternalformat-macro
  717.     (not (eobp))
  718.       ;; This progn is not strictly necessary, but it serves to delimit the
  719.       ;; extent of the body of read-database-file-noninternalformat-macro.
  720.       (progn
  721.     ;; (debug "in read-database-file-delimited-macro")
  722.     ;; (db-message "read-database-file-delimited-regexp:  not eobp at %s/%s" (point) (point-max))
  723.     (setq this-record (make-vector no-of-fields nil))
  724.  
  725.     ;; Note that in this case I didn't want to get rid of the pre-first stuff.
  726.     (if pre-first-field-regexp
  727.         (if (skip-regexp-forward pre-first-field-regexp)
  728.         (progn
  729.           (setq here (match-end pre-first-field-regexp-submatch))
  730.           (goto-char here))
  731.           (error "Didn't find pre-first stuff I expected.")))
  732.  
  733.     (setq field-no 0)
  734.     (while (< field-no max-field-no)
  735.      
  736.       ;; I should trap errors here.  Don't check for record-regexp in the
  737.       ;; field text, however, because that's too slow.
  738.      
  739.       (if (re-search-forward field-regexp nil t)
  740.           (progn
  741.         (record-set-field-from-index
  742.          this-record field-no
  743.          (buffer-substring here
  744.                    (match-beginning field-regexp-submatch))
  745.          nil)
  746.         (setq here (match-end field-regexp-submatch))
  747.         (setq field-no (1+ field-no)))
  748.         (progn
  749.           (db-warning "Hit the end of the database after %d fields of record %d (didn't find field-regexp `%s')"
  750.               field-no dbc-index field-regexp)
  751.           (setq field-no max-field-no))))
  752.     (if (re-search-forward record-regexp nil t)
  753.         (setq end-of-record-regexp (match-end record-regexp-submatch)
  754.           end-of-record (match-beginning record-regexp-submatch))
  755.       (progn
  756.         (db-warning "Didn't find `%s' at end of last field of record %d."
  757.             record-regexp dbc-index)
  758.         (setq end-of-record-regexp (point-max)
  759.           end-of-record (point-max))))
  760.     (goto-char here)
  761.     (if (re-search-forward field-regexp end-of-record t)
  762.         (progn
  763.           (db-warning "Too many fields in record %d; packing them all into the last field; beware when writing."
  764.               dbc-index)
  765.           (setq db-io-error-p t)))
  766.     (record-set-field-from-index this-record max-field-no
  767.                      (buffer-substring here
  768.                                end-of-record)
  769.                      nil)
  770.     (goto-char end-of-record-regexp)
  771.     (setq here (point))))
  772.  
  773.  
  774.     (database-stored->actual database)
  775.  
  776.     database))
  777.  
  778.  
  779. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  780. ;;; Read database utilities
  781. ;;;
  782.  
  783.  
  784. ;; Each field of each database record has a string; convert some of these
  785. ;; into some other internal representation (or even into different
  786. ;; strings).
  787.  
  788. ;;   "Convert string slot values in a newly-read database to the actual format.
  789. ;; If no argument is specified, use the value of the dynamic variable  database.
  790. ;; This makes it possible to be put directly in  db-after-read-hook."
  791. (defun database-stored->actual (&optional db)
  792.  
  793.   (database-stored->actual-internal (or db database)))
  794.  
  795.  
  796. ;; The following function used to be part of the above function, but
  797. ;; edebug2.7 had trouble debugging it for some reason.
  798.  
  799. ;;   "Do the real work of `database-stored->actual'."
  800. (defun database-stored->actual-internal (db)
  801.   (let (fno-s->a-alist
  802.     s->a
  803.     (field-no 0)
  804.     field-val
  805.     (no-of-fields (database-no-of-fields db)))
  806.     (while (< field-no no-of-fields)
  807.       (setq s->a (recordfieldspec-stored->actual
  808.           (database-recordfieldspec db field-no)))
  809.       (if s->a
  810.       (setq fno-s->a-alist
  811.         (cons (cons field-no s->a) fno-s->a-alist)))
  812.       (setq field-no (1+ field-no)))
  813.     (db-debug-message "database-stored->actual:  fno-s->a-alist = %s" fno-s->a-alist)
  814.     (if fno-s->a-alist
  815.     (progn
  816.       (db-message "Converting from stored record format...")
  817.       (maprecords-macro
  818.        (let ((s->a-pairs fno-s->a-alist))
  819.          (while s->a-pairs
  820.            (setq field-no (car (car s->a-pairs))
  821.              field-val (aref maprecords-record field-no)
  822.              s->a (cdr (car s->a-pairs))
  823.              s->a-pairs (cdr s->a-pairs))
  824.            (record-set-field-from-index
  825.         maprecords-record field-no
  826.         (if (stringp field-val)
  827.             (funcall s->a field-val)
  828.           field-val)
  829.         nil)))
  830.        db nil "Converting record format...%s")
  831.       (db-message "Converting record format...done.")))))
  832.  
  833. ;; Takes a database file as input, reads the auxiliary file if it can.
  834. ;; Note that the `database' variable is dynamically bound when the
  835. ;; auxiliary file is read.
  836. (defun read-db-aux-file (database)
  837.   (let ((aux-file (or (database-aux-file database)
  838.                (locate-file-with-extensions-on-path
  839.             (database-file database)
  840.             db-aux-file-suffixes db-aux-file-path))))
  841.     (if aux-file
  842.     (load-file aux-file))))
  843.  
  844. ;; This only does the RECORD separators.
  845. ;;   "Modify current buffer according to DATABASE.
  846. ;; Remove pre-first-record- and post-last-record strings or regexps, then
  847. ;; add a field separator to the end so that every record is terminated by one."
  848. (defun database-delete-pre-and-post (database)
  849.  
  850.   (let ((record-sepinfo (database-record-sepinfo database)))
  851.  
  852.     ;; Remove gubbish before first record.
  853.     (goto-char (point-min))
  854.     (let ((pre-first-record-string (sepinfo-pre-first-string
  855.                     record-sepinfo))
  856.       (pre-first-record-regexp (sepinfo-pre-first-regexp
  857.                     record-sepinfo)))
  858.       (cond (pre-first-record-regexp
  859.          (if (skip-regexp-forward pre-first-record-regexp)
  860.          (progn
  861.            (goto-char (match-end (sepinfo-pre-first-regexp-submatch
  862.                         record-sepinfo)))
  863.            (delete-region (point-min) (point)))
  864.            (error "Didn't find match for regexp `%s' leading the data."
  865.               pre-first-record-string)))
  866.         (pre-first-record-string
  867.          (if (skip-string-forward pre-first-record-string)
  868.          (delete-region (point-min) (point))
  869.            (error "Didn't find string `%s' leading the data."
  870.               pre-first-record-string)))))
  871.  
  872.     ;; Remove gubbish after last record.
  873.     (goto-char (point-max))
  874.     (let ((post-last-record-string (sepinfo-post-last-string
  875.                     record-sepinfo))
  876.       (post-last-record-regexp (sepinfo-post-last-regexp
  877.                     record-sepinfo)))
  878.       (db-debug-message "database-delete-pre-and-post:  post-string = `%s', post-regexp = `%s'" post-last-record-string post-last-record-regexp)
  879.       (cond (post-last-record-regexp
  880.          (if (re-search-backward post-last-record-regexp)
  881.          (progn
  882.            (db-debug-message "regexp-deleting %d to %d" (point) (point-max))
  883.            (goto-char (match-beginning (sepinfo-post-last-regexp-submatch
  884.                         record-sepinfo)))
  885.            (delete-region (point) (point-max)))
  886.            (error "Didn't find match for post-last-record-regexp `%s'."
  887.               post-last-record-string)))
  888.         (post-last-record-string
  889.          (if (search-backward post-last-record-string)
  890.          (delete-region (point) (point-max))
  891.            (error "Didn't find post-last-record-string `%s'."
  892.               post-last-record-string)))))
  893.  
  894.     ;; (debug)
  895.  
  896.     ;; Problem:  what if only regexp (not sep-string) is specified?
  897.     ;; Then this crashes.
  898.  
  899.     ;; Maybe this should be happening in the caller, not here.
  900.     ;; If there isn't one there already, add a final record separator so that
  901.     ;; every record is terminated by one.
  902.     (let ((sep-string (sepinfo-sep-string record-sepinfo)))
  903.       (db-debug-message "sep-string = `%s'" sep-string)
  904.       (if (not (skip-string-backward sep-string))
  905.       (insert sep-string)))
  906.     ))
  907.  
  908.  
  909. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  910. ;;; Write database file
  911. ;;;
  912.  
  913.  
  914. ;; This is called from the data display buffer, and we need the values of
  915. ;; variables local to that buffer.  It used to do output to the end of that
  916. ;; buffer, call write-region, and finally delete the output, but now it
  917. ;; uses a different buffer.
  918.  
  919. ;; I process-current-record before calling this from
  920. ;; db-write-database-file, and it isn't called from anywhere else.
  921.  
  922. (defun write-database-file (database &optional db-file)
  923.  
  924.   (setq db-io-error-p nil)
  925.   (if db-file
  926.       (if (or (not (file-name-directory db-file))
  927.           (file-exists-p (file-name-directory db-file)))
  928.       (database-set-file database db-file)
  929.     (error "Can't write %s: directory does not exist." db-file))
  930.     (setq db-file (database-file database)))
  931.  
  932.   (in-buffer (generate-new-buffer "write-database-file")
  933.     (buffer-flush-undo (current-buffer))
  934.     (auto-save-mode 0)
  935.     (if (database-internal-file-layout-p database)
  936.     (let ((fl (database-first-link database))
  937.           (ddbs (database-data-display-buffers database))
  938.           (modified-p (database-modified-p database))
  939.           (standard-output (current-buffer)))
  940.       (insert ";; Database file written by EDB; format 0.4\n")
  941.       (unwind-protect
  942.           (progn
  943.         (database-set-first-link database nil)
  944.         (database-set-data-display-buffers database nil)
  945.         (database-set-modified-p database nil)
  946.         (print database))
  947.         (database-set-first-link database fl)
  948.         (database-set-data-display-buffers database ddbs)
  949.         ;; in case we abort out of the write
  950.         (database-set-modified-p database modified-p)
  951.         )
  952.       (insert "(\n")
  953.       (maprecords (function print) database)
  954.       (insert "\n)\n")
  955.       ;; This is not catching the error raised by basic-save-buffer if
  956.       ;; the destination is not writable.
  957.       (condition-case error
  958.           (let ((require-final-newline nil)
  959.             ;; get around write-file
  960.             (auto-save-default nil))
  961.         (write-file db-file)
  962.         (database-set-modified-p database nil)
  963.         (kill-buffer (current-buffer))
  964.         )
  965.         ;; Used to be file-error, which didn't catch the error raised
  966.         ;; by basic-save-buffer if the destination is not writable.
  967.         (error
  968.          (setq db-io-error-p t)
  969.          ;; This must come before the buffer is killed.
  970.          (db-warning "Error `%s' while writing buffer %s to file %s."
  971.              error (buffer-name (current-buffer)) db-file)
  972.          ;; This ignores  db-disable-debugging-support-p.  Oh, well.
  973.          (if (not db-debug-p)
  974.          (progn
  975.            ;; avoid further questions about killing the buffer.
  976.            (set-buffer-modified-p nil)
  977.            (kill-buffer (current-buffer))))))
  978.       )
  979.       ;; Don't use internal representation.
  980.       (progn
  981.     ;; Fine example of use of undocumented functionality
  982.     ;; (this-buffer is bound by in-buffer).
  983.     (db-debug-message "Calling copy-buffer-local-variables.")
  984.     (copy-buffer-local-variables this-buffer)
  985.     ;; We don't want to be *exactly* like the data display buffer.
  986.     (setq major-mode 'write-database-mode
  987.           buffer-read-only nil)
  988.     (database-io-setup database)
  989.     (let ((first-record t)
  990.           (record-sepinfo (database-record-sepinfo database)))
  991.       (db-debug-message "About to insert-maybe pre-first-record-string `%s'."
  992.                 (sepinfo-pre-first-string record-sepinfo))
  993.       (if (sepinfo-pre-first-string record-sepinfo)
  994.           (insert (sepinfo-pre-first-string record-sepinfo)))
  995.       (if (database-write-region-from-record database)
  996.           ;; Don't do any separator checking at all in the case of
  997.           ;; write-record-function, even for recordsep, since I have no
  998.           ;; idea how clever read-record-function is going to be.  Also
  999.           ;; don't do substitution or quoting.  Probably I shouldn't even
  1000.           ;; be inserting record-sep-string, but it will probably be the
  1001.           ;; empty string anyway.  [Another possibility is that if
  1002.           ;; I don't want it in the speciialized reading/writing
  1003.           ;; functions, I could just set the substitutions list to nil.]
  1004.           (let ((record-sep-string (sepinfo-sep-string record-sepinfo))
  1005.             (write-region-fn (database-write-region-from-record
  1006.                       database)))
  1007.         (db-message "Writing database...")
  1008.         (maprecords (function (lambda (record)
  1009.                     (if first-record
  1010.                         (setq first-record nil)
  1011.                       (insert record-sep-string))
  1012.                     (funcall write-region-fn record)))
  1013.                 database nil "Writing database...%d")
  1014.         (db-message "Writing database to disk..."))
  1015.         (write-database-file-internal-delimited database))
  1016.       (db-debug-message "done with write-database-file-internal-delimited")
  1017.       (if (sepinfo-post-last-string record-sepinfo)
  1018.           (insert (sepinfo-post-last-string record-sepinfo)))
  1019.      
  1020.       ;; Add the local variables, if any, to the end.
  1021.       (if (database-file-local-variables database)
  1022.           (insert (database-file-local-variables database)))
  1023.  
  1024.       (condition-case error
  1025.           (let ((require-final-newline nil)
  1026.             ;; get around write-file
  1027.             (auto-save-default nil))
  1028.         (write-file db-file)
  1029.         (database-set-modified-p database nil)
  1030.         (kill-buffer (current-buffer))
  1031.         )
  1032.         ;; Used to be file-error, which didn't catch the error raised
  1033.         ;; by basic-save-buffer if the destination is not writable.
  1034.         (error
  1035.          (setq db-io-error-p t)
  1036.          ;; This must come before the buffer is killed.
  1037.          (db-warning "Error `%s' while writing buffer %s to file %s."
  1038.              error (buffer-name (current-buffer)) db-file)
  1039.          ;; Did write-file 
  1040.          (auto-save-mode 0)
  1041.          ;; This ignores  db-disable-debugging-support-p.  Oh, well.
  1042.          (if (not db-debug-p)
  1043.          (progn
  1044.            ;; avoid further questions about killing the buffer.
  1045.            (set-buffer-modified-p nil)
  1046.            (kill-buffer (current-buffer))))))
  1047.       ))
  1048.       )
  1049.     )
  1050.   ;; In case we wrote the curently-visible database.  This probably fails
  1051.   ;; if both the data display buffer and the summary buffer are visible.
  1052.   ;; I guess I should have a procedure that fixes the modified bit for the
  1053.   ;; mode lines of both buffers.
  1054.   (if (database-buffer-p)
  1055.       (progn
  1056.     (dbc-update-database-modified-p)
  1057.     (force-mode-line-update)))
  1058.   )
  1059.  
  1060.  
  1061. ;; This inserts the records, fields separated by fieldsep and records
  1062. ;; separated by recordsep, into the current buffer; it uses delimited
  1063. ;; format.  It is called by write-database-file, which arranges
  1064. ;; unwind-protect boundaries, calls the -internal function that uses the
  1065. ;; proper output file layout, etc.
  1066. (defun write-database-file-internal-delimited (database)
  1067.  
  1068.   (let* ((previous-point (point))
  1069.      (fno 0)
  1070.      (first-record t)
  1071.      (no-of-fields (database-no-of-fields database))
  1072.      (write-record-function (database-write-region-from-record database))
  1073.      (fieldsep-string (database-full-fieldsep-string database))
  1074.      (recordsep-string (database-full-recordsep-string database))
  1075.      (sub-fieldsep (or (database-sub-fieldsep-string database) fieldsep-string))
  1076.      (sub-recordsep (or (database-sub-recordsep-string database) recordsep-string))
  1077.      confirmation-list)
  1078.  
  1079.     ;; Check the delimiters
  1080.     (if (not (database-acceptable-delimiter-p sub-fieldsep))
  1081.     (setq sub-fieldsep (database-generate-delimiter nil)))
  1082.     (if (not (database-acceptable-delimiter-p sub-recordsep))
  1083.     (setq sub-recordsep (database-generate-delimiter nil)))
  1084.  
  1085.     (db-message "Writing database...")
  1086.     (maprecords
  1087.      (function
  1088.       (lambda (record)
  1089.     ;; (db-debug-message "record %s about to be written." record)
  1090.  
  1091.     ;; This isn't abstracted out, partly because I don't want to pay the
  1092.     ;; overhead of a function call.
  1093.  
  1094.     (setq fno 0)
  1095.     (while (< fno no-of-fields)
  1096.       (if (> fno 0) (insert sub-fieldsep))
  1097.       ;; this is record-field-stored, inlined.
  1098.       (insert (funcall-maybe (recordfieldspec-actual->stored
  1099.                   (database-recordfieldspec database fno))
  1100.                  (aref record fno)))
  1101.       (setq fno (1+ fno)))
  1102.     (insert sub-recordsep)))
  1103.      database nil "Writing database...%d")
  1104.     ;; (db-debug-message "wrote all records.")
  1105.  
  1106.     (db-message "Writing database...confirming")
  1107.  
  1108.     (narrow-to-region previous-point (point-max))
  1109.     (setq confirmation-list (database-confirm-fieldsep-and-recordsep
  1110.                   sub-fieldsep sub-recordsep
  1111.                   (database-no-of-fields database)
  1112.                   (database-no-of-records database)))
  1113.     (db-debug-message "write-database-file-internal-delimited:\n  confirmation-list = %s" confirmation-list)
  1114.     (if (or (conflist-fieldsep-bad-p confirmation-list)
  1115.         (conflist-recordsep-bad-p confirmation-list))
  1116.     (progn
  1117.       (db-debug-message "confirmation failed")
  1118.       (if (conflist-fieldsep-bad-p confirmation-list)
  1119.           (progn
  1120.         (db-warning "Tripped over an unexpected field separator `%s' in data; trying again."
  1121.                 sub-fieldsep)
  1122.         (database-set-sub-fieldsep-string database
  1123.               (database-generate-delimiter database t))))
  1124.       (if (conflist-recordsep-bad-p confirmation-list)
  1125.           (progn
  1126.         (db-warning "Tripped over an unexpected record separator `%s' in data; trying again."
  1127.              sub-recordsep)
  1128.         (database-set-sub-recordsep-string database
  1129.               (database-generate-delimiter database t))))
  1130.  
  1131.       ;; We've chosen new separators; erase the work so far.
  1132.       (delete-region previous-point (point))
  1133.  
  1134.       ;; Call this function recursively.
  1135.       (write-database-file-internal-delimited database)
  1136.       ;; I've called this recursively; don't do any substitution
  1137.       ;; or quoting.
  1138.       )
  1139.       ;; Confirmation was OK:  correct number of field and record
  1140.       ;; separators found.
  1141.       (progn
  1142.     (db-debug-message "confirmation succeeded")
  1143.  
  1144.     ;; Put off adding the pre- and post- field strings until
  1145.     ;; after checking separators, as they may contain anomolous
  1146.     ;; field separators, for instance.
  1147.  
  1148.     ;; But do it before substitution so that all field pre- and
  1149.     ;; post- strings are treated identically.
  1150.  
  1151.     ;; The whole point of using io-separators is so they
  1152.     ;; appear exactly as the user specified, unaffected by
  1153.     ;; substitution.
  1154.  
  1155.  
  1156.     ;; But note that pre- and post- record strings will be added
  1157.     ;; later, after substitution.
  1158.  
  1159.     (database-substitute-for-write database
  1160.                        fieldsep-string sub-fieldsep
  1161.                        recordsep-string sub-recordsep)
  1162.     ;; Convert from "simple" to "complex" form.
  1163.     (goto-char (point-min))
  1164.     (let ((pre-first (sepinfo-pre-first-string (database-field-sepinfo database))))
  1165.       (if pre-first
  1166.           (insert pre-first)))
  1167.  
  1168.     (goto-char (point-max))
  1169.     (db-debug-message "at point-max")
  1170.     (if (and (skip-string-backward (or (sepinfo-pre-first-string
  1171.                         (database-field-sepinfo database))
  1172.                        ""))
  1173.          (skip-string-backward (or (sepinfo-sep-string
  1174.                         (database-record-sepinfo database))
  1175.                        "")))
  1176.         (delete-region (point) (point-max))
  1177.       (error "Didn't find expected trailing junk `%s' or `%s'."
  1178.          (sepinfo-pre-first-string (database-field-sepinfo database))
  1179.          (sepinfo-sep-string (database-record-sepinfo database))))
  1180.     (db-debug-message "about to widen")
  1181.  
  1182.  
  1183.     ))
  1184.     (widen)))
  1185.  
  1186.  
  1187. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1188. ;;; I/O utilities
  1189. ;;;
  1190.  
  1191. (defun database-io-setup (database &optional dont-set-regexps)
  1192.  
  1193.   ;; Perhaps these should be dealt with via with- forms as well.
  1194.   ;; Or have local variables that they set.
  1195.   ;; Or global ones that they set unconditionally.
  1196.  
  1197.   ;; Some of this information may already be correctly set (especially if
  1198.   ;; we're now writing), but just in case some of the database slots have
  1199.   ;; changed since reading (eg, quotation character is different now).
  1200.  
  1201.   (db-debug-message "database-io-setup called.")
  1202.   (database-check-all-sepinfos database dont-set-regexps)
  1203.   (db-debug-message "database-check-all-sepinfos returned in database-io-setup.")
  1204.   (db-set-field-quotation-vars database)
  1205.   (setq db-substitution-no-no-string
  1206.     (apply (function concat)
  1207.            (mapcar (function (lambda (string-cons)
  1208.                    (concat (car string-cons)
  1209.                        (cdr string-cons))))
  1210.                (database-substitutions database))))
  1211.   (db-debug-message "database-io-setup returning.")
  1212.   )
  1213.  
  1214.  
  1215. ;;; The user should set the slots directly.
  1216. ;; Doesn't set unless the variables are non-nil.
  1217. ;; (defun set-database-slots-from-buffer-local-values-maybe (database)
  1218. ;;   (if db-record-fieldnames
  1219. ;;       (database-set-fieldnames database db-record-fieldnames))
  1220. ;;   (if db-substitutions
  1221. ;;       (database-set-substitutions database db-substitutions)))
  1222.  
  1223. ;; This is the stuff that needs to happen before the format is parsed but after
  1224. ;; the format's local variables have been hacked.
  1225. ;; It has nothing to do with the format per se, only with database slots.
  1226. ;; Keep it abstracted out!
  1227. (defun db-set-field-variables (database)
  1228.   ;; This is now done by database-set-fieldnames-to-list.
  1229.   ;; (db-set-fieldname-vars database)
  1230.   (if (not (database-field-priorities database))
  1231.       (database-set-field-priorities database
  1232.         (let ((fno -1))
  1233.           (cons
  1234.            (mapcar (function (lambda (fieldname)
  1235.                    (setq fno (1+ fno))
  1236.                    (list fno)))
  1237.                (database-fieldname-alist database))
  1238.            nil)))))
  1239.  
  1240.  
  1241. ;; When converting strings to regexps, must be careful to watch out for
  1242. ;; substitution and quotation:  don't get fooled.
  1243. (defun database-check-all-sepinfos (database &optional dont-set-regexps)
  1244.  
  1245.   ;; When writing to the file, we take the previous version's local
  1246.   ;; variables section verbatim.
  1247.  
  1248.   ;; We're only setting the regexp variables, which the average user won't
  1249.   ;; touch.
  1250.  
  1251.   ;; When reading, we'll get the variables from the database, auxiliary,
  1252.   ;; and format files anew each time anyway.
  1253.  
  1254.   (database-check-sepinfo (database-record-sepinfo database) database
  1255.               "record" "\n" dont-set-regexps)
  1256.   (database-check-sepinfo (database-field-sepinfo database) database
  1257.               "field" "\t" dont-set-regexps)
  1258.   (database-check-sepinfo (database-alternative-sepinfo database) database
  1259.               "alternative" t dont-set-regexps)
  1260.   )
  1261.  
  1262.  
  1263. ;; It's good that this setting of -regexp slots doesn't happen until the
  1264. ;; last possible moment, when quotation-char and other variables that these
  1265. ;; values depend on are already set to their final values.
  1266.  
  1267. (defun database-check-sepinfo (sepinfo database sepinfo-name
  1268.                        &optional sep-string-default dont-set-regexps)
  1269.  
  1270.   ;; If the sep-string slot of the sepinfo is nil, then:
  1271.   ;;  * if SEP-STRING-DEFAULT is nil, signal an error.
  1272.   ;;  * if SEP-STRING-DEFAULT is t, do nothing.
  1273.   ;;  * otherwise set the slot to SEP-STRING-DEFAULT.
  1274.  
  1275.   ;; If the string is the empty string, then we must have just set it that
  1276.   ;; way, which means that we either also just set the regexp to nil,
  1277.   ;; or we set the regexp to something we care about.  In either case don't
  1278.   ;; mess further with the regexp.
  1279.  
  1280.   ;; The submatches could default to 0 if they're nil; but I want to be
  1281.   ;; more paranoid than that.
  1282.  
  1283.   (if (and (sepinfo-pre-first-string sepinfo)
  1284.        (equal "" (sepinfo-pre-first-string sepinfo)))
  1285.       ;; pre-first-string = ""
  1286.       (sepinfo-set-pre-first-string sepinfo nil))
  1287.   (if (sepinfo-pre-first-regexp sepinfo)
  1288.       (if (not (sepinfo-pre-first-regexp-submatch sepinfo))
  1289.       (error "Need a submatch to go with pre-first-regexp `%s' of %s."
  1290.          (sepinfo-pre-first-regexp sepinfo) sepinfo-name))
  1291.     (if (and (sepinfo-pre-first-string sepinfo)
  1292.          (not dont-set-regexps))
  1293.     (sepinfo-set-regexp-and-submatch-from-string
  1294.      sepinfo-set-pre-first-regexp sepinfo-set-pre-first-regexp-submatch
  1295.      sepinfo
  1296.      (sepinfo-pre-first-string sepinfo) database)))
  1297.  
  1298.   ;; Don't test for sep-function because the sepinfo must be valid for
  1299.   ;; output as well as input.
  1300.   ;; On the other hand, we don't need sep-string to be set if a wrfr
  1301.   ;; function is in use, but this function doesn't do any such checks.
  1302.   (if (or (not (sepinfo-sep-string sepinfo))
  1303.       (and (equal "" (sepinfo-sep-string sepinfo))
  1304.            (not (sepinfo-sep-regexp sepinfo))))
  1305.       ;; sep-string isn't set appropriately; it contains no information
  1306.       (cond ((eq t sep-string-default)
  1307.          ;; do nothing
  1308.          )
  1309.         ((not sep-string-default)
  1310.          (error "Sep-string must be non-empty in %s." sepinfo-name))
  1311.         (t
  1312.          (sepinfo-set-sep-string sepinfo sep-string-default))))
  1313.   (if (sepinfo-sep-regexp sepinfo)
  1314.       (if (not (sepinfo-sep-regexp-submatch sepinfo))
  1315.       (error "Need a submatch to go with sep-regexp `%s' of %s."
  1316.          (sepinfo-sep-regexp sepinfo) sepinfo-name))
  1317.     (if (and (not (sepinfo-sep-function sepinfo))
  1318.          (not dont-set-regexps))
  1319.     (sepinfo-set-regexp-and-submatch-from-string
  1320.      sepinfo-set-sep-regexp sepinfo-set-sep-regexp-submatch sepinfo
  1321.      (sepinfo-sep-string sepinfo) database)))
  1322.  
  1323.   (if (and (sepinfo-post-last-string sepinfo)
  1324.        (equal "" (sepinfo-post-last-string sepinfo)))
  1325.       (sepinfo-set-post-last-string sepinfo nil))
  1326.   (if (sepinfo-post-last-regexp sepinfo)
  1327.       (if (not (sepinfo-post-last-regexp-submatch sepinfo))
  1328.       (error "Need a submatch to go with post-last-regexp `%s' of %s."
  1329.          (sepinfo-post-last-regexp sepinfo) sepinfo-name))
  1330.     (if (and (sepinfo-post-last-string sepinfo)
  1331.          (not dont-set-regexps))
  1332.     (sepinfo-set-regexp-and-submatch-from-string
  1333.      sepinfo-set-post-last-regexp sepinfo-set-post-last-regexp-submatch
  1334.      sepinfo
  1335.      (sepinfo-post-last-string sepinfo) database))))
  1336.  
  1337.  
  1338. (defun when-not-preceded-by-quotation-char (string database)
  1339.   (concat
  1340.    "[^" (database-quotation-char database) "]"
  1341.    "\\("
  1342.    (regexp-quote (make-string 2 (database-quotation-char database)))
  1343.    "\\)*"
  1344.    "\\(" (regexp-quote string) "\\)"))
  1345.  
  1346. ;; These are macros because we're doing a setq on the variable names.
  1347.  
  1348. ;; Shouldn't be using this global variable "database", perhaps.
  1349.  
  1350. ;; Note that each argument will be evaluated only once; no need to let
  1351. ;; a gensym to (, string), though that might result in smaller code.
  1352.  
  1353.  
  1354. ;; (defmacro setf-regexp-and-submatch-from-string
  1355. ;;   (regexp-name submatch-name string database)
  1356. ;;   (` (let ((str (, string))
  1357. ;;        (db (, database)))
  1358. ;;        (cond ((or (null str) (equal "" str))
  1359. ;;           ((!!) setf (, regexp-name) nil
  1360. ;;             (, submatch-name) nil))
  1361. ;;          ((database-quotation-char db)
  1362. ;;           ((!!) setf (, regexp-name) (when-not-preceded-by-quotation-char
  1363. ;;                      str db)
  1364. ;;             (, submatch-name) 2))
  1365. ;;          (t
  1366. ;;           ((!!) setf (, regexp-name) (regexp-quote str)
  1367. ;;             (, submatch-name) 0))))))
  1368.  
  1369.  
  1370. ;; REGEXP-NAME and SUBMATCH-NAME are symbols
  1371. (defmacro sepinfo-set-regexp-and-submatch-from-string
  1372.   (regexp-setter submatch-setter sepinfo string database)
  1373.   (` (let ((str (, string))
  1374.        (db (, database))
  1375.        (si (, sepinfo)))
  1376.        (cond ((or (null str) (equal "" str))
  1377.           ((, regexp-setter) si nil)
  1378.           ((, submatch-setter) si nil))
  1379.          ((database-quotation-char db)
  1380.           ((, regexp-setter) si (when-not-preceded-by-quotation-char
  1381.                      str db))
  1382.           ((, submatch-setter) si 2))
  1383.          (t
  1384.           ((, regexp-setter) si (regexp-quote str))
  1385.           ((, submatch-setter) si 0))))))
  1386.  
  1387. ;; All this hinges on the database fieldnames, which has been set to a list
  1388. ;; but will now be converted to a vector.
  1389.  
  1390. ;;   "Set variables and slots of DATABASE that can be set from optional argument
  1391. ;; FIELDNAMES-LIST or, if it is nil, from the fieldnames slot of the database."
  1392. (defun db-set-fieldname-vars (database &optional fieldnames-list)
  1393.   (if (not fieldnames-list)
  1394.       (setq fieldnames-list (database-fieldnames database)))
  1395.   (db-debug-message "db-set-fieldname-vars:  %s" fieldnames-list)
  1396.  
  1397.   ;; the `type' variable can be done away with.
  1398.   (let* ((no-of-fields (length fieldnames-list))
  1399.      (fno -1)
  1400.      type
  1401.      (recordfieldspecs (make-vector no-of-fields nil))
  1402.      (fieldnames-vector (make-vector no-of-fields nil)))
  1403.     (database-set-fieldname-alist database
  1404.       (mapcar (function
  1405.            (lambda (fname)
  1406.              (setq fno (1+ fno)
  1407.                type (if (consp fname)
  1408.                     (prog1 (cdr fname)
  1409.                       (setq fname (car fname)))
  1410.                   db-default-field-type))
  1411.              (db-debug-message "%s %s %s" fname fno type)
  1412.              (if (recordfieldtype-p type)
  1413.              (aset recordfieldspecs fno type)
  1414.                (error "db-set-fieldname-vars:  bad type %s" type))
  1415.              (aset fieldnames-vector fno fname)
  1416.              (cons fname fno)))
  1417.           fieldnames-list))
  1418.     ;; (db-debug-message "set-recordfieldspec-vars:  recordfieldspec-fieldnames = %s" fieldnames-list)
  1419.     ;; (db-debug-message "set-recordfieldspec-vars:  recordfieldspec-fieldname-alist = %s" fieldnames-and-numbers)
  1420.     (database-set-no-of-fields database no-of-fields)
  1421.     (database-set-fieldnames database fieldnames-vector)
  1422.     (database-set-recordfieldspecs database recordfieldspecs)))
  1423.  
  1424. ;; (defun set-db-vars (database)
  1425. ;;   (db-set-field-quotation-vars database))
  1426.  
  1427. (defun recordfieldtype->recordfieldspec (recordfieldtype)
  1428.   "Return the recordfieldspec associated with symbol RECORDFIELDTYPE."
  1429.   (let ((result (cdr (assoc recordfieldtype db-recordfieldtypes))))
  1430.     (cond ((recordfieldspec-p result)
  1431.        result)
  1432.       ((symbolp result)
  1433.        ;; recursive call
  1434.        (recordfieldtype->recordfieldspec result)))))
  1435. ;; Was inlined when there was no chance of a recursive call.
  1436. ;; (proclaim-inline recordfieldtype->recordfieldspec)
  1437. ;; Not really necessary even now.
  1438. ;; (proclaim-notinline recordfieldtype->recordfieldspec)
  1439.  
  1440. (defun recordfieldtype-p (recordfieldtype)
  1441.   (assoc recordfieldtype db-recordfieldtypes))
  1442.  
  1443.  
  1444. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1445. ;;; Substitution
  1446. ;;;
  1447.  
  1448. ;; When substitution is called, the database is always in "simple" format:
  1449. ;; fields are separated by sub-fieldsep, and records (including the last
  1450. ;; one) are followed by sub-recordsep.
  1451.  
  1452. ;; The "complicated" format includes pre-first-field at the beginning and
  1453. ;; post-last-field (without record-sep-string or pre-first-field, which are
  1454. ;; the other elements of sub-recordsep) at the end.
  1455.  
  1456. ;; Simple format is nice because it requires no special-casing at the
  1457. ;; beginning (because there's no gubbish there) or at the end (because
  1458. ;; what's there is exactly what's between each pair of records).
  1459.  
  1460. ;; The caller of database-substitute-for-* arranges to convert to/from
  1461. ;; simple format before/after the call.
  1462.  
  1463. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1464.  
  1465. ;; This is called only by read-database-file-delimited.
  1466.  
  1467. ;; Its purspose is to convert field/record separators (perhaps choosing new
  1468. ;; ones), so they won't get damaged by the substitution, and then doing the
  1469. ;; substitution.  It also must set the sub-{field,record}sep slots, because
  1470. ;; later on in read-database-file-delimited-internal, those fields are
  1471. ;; slavishly followed.
  1472.  
  1473. ;; No substitution should occur if either of the separators is a regexp, as
  1474. ;; I can't parse them (or do substitution in them).
  1475.  
  1476. ;; Perhaps it should trust the settings for sub-fieldsep et al in the
  1477. ;; database, and not do anything if they're set?
  1478.  
  1479. (defun database-substitute-for-read (database)
  1480.   (let* ((fieldsep-orig (database-full-fieldsep-string database))
  1481.      (recordsep-orig (database-full-recordsep-string database))
  1482.      (fieldsep-sub (or (database-sub-fieldsep-string database)
  1483.                fieldsep-orig))
  1484.      (recordsep-sub (or (database-sub-recordsep-string database)
  1485.                 recordsep-orig)))
  1486.  
  1487.     ;; fieldsep-sub and recordsep-sub are never used after this!
  1488.     (db-debug-message "d-s-f-r `%s' `%s' `%s' `%s'"
  1489.               fieldsep-orig recordsep-orig fieldsep-sub recordsep-sub)
  1490.  
  1491.     (if (or (sepinfo-sep-regexp (database-record-sepinfo database))
  1492.         (sepinfo-sep-regexp (database-field-sepinfo database)))
  1493.     (progn
  1494.       (database-set-sub-recordsep-string database
  1495.          (or (sepinfo-sep-regexp (database-record-sepinfo database))
  1496.          (database-sub-recordsep-string database)
  1497.          recordsep-orig))
  1498.       (database-set-sub-fieldsep-string database
  1499.          (or (sepinfo-sep-regexp (database-field-sepinfo database))
  1500.          (database-sub-fieldsep-string database)
  1501.          fieldsep-orig)))
  1502.       ;; No regexps to be found.
  1503.       (progn
  1504.     ;; If the recordsep is a substring of fieldsep, this order is a
  1505.     ;; disaster (unless we do substitution in the fieldsep string as well
  1506.     ;; as in the buffer, which is an interesting idea); perhaps get some
  1507.     ;; info back in the confirmation list about that, too.  Or just trust
  1508.     ;; that that won't happen; fieldsep being a substring of recordsep is
  1509.     ;; much more likely, after all.
  1510.  
  1511.     ;; Since I'll be checking against a database file on which
  1512.     ;; substitution has already been performed, will the order of
  1513.     ;; reverse substitution be important?
  1514.  
  1515.     (db-debug-message "Checking recordsep-orig `%s'." recordsep-orig)
  1516.     (if (not recordsep-orig)
  1517.         (error "No record separator specified."))
  1518.     (if (database-acceptable-delimiter-p recordsep-orig)
  1519.         (database-set-sub-recordsep-string database recordsep-orig)
  1520.       (progn
  1521.         (db-message "Substituting record delimiter for read...")
  1522.         (database-set-sub-recordsep-string database
  1523.                     (database-generate-delimiter database))
  1524.         (db-debug-message "Substituting record delimiter for read... (`%s' for `%s')"
  1525.                   (database-sub-recordsep-string database) recordsep-orig)
  1526.         (goto-char (point-min))
  1527.         (replace-string recordsep-orig (database-sub-recordsep-string database))
  1528.         (setq fieldsep-orig (string-substitute-substring-general-case
  1529.                  (database-sub-recordsep-string database) recordsep-orig
  1530.                  fieldsep-orig))
  1531.         (db-message "Substituting record delimiter for read...done")
  1532.         ))
  1533.  
  1534.     (db-debug-message "Checking fieldsep-orig `%s'." fieldsep-orig)
  1535.     (if (or (database-acceptable-delimiter-p fieldsep-orig)
  1536.         (database-read-record-from-region database))
  1537.         (progn
  1538.           (db-message "fieldsep-orig `%s' is acceptable." fieldsep-orig)
  1539.           (db-message "because (or %s %s)"
  1540.                (database-acceptable-delimiter-p fieldsep-orig)
  1541.                (database-read-record-from-region database))
  1542.           (database-set-sub-fieldsep-string database fieldsep-orig))
  1543.       (progn
  1544.         (if (not fieldsep-orig)
  1545.         (error "No field separator specified."))
  1546.         (db-message "Substituting field delimiter for read...")
  1547.         (database-set-sub-fieldsep-string database
  1548.                        (database-generate-delimiter database))
  1549.         (db-message "Substituting field delimiter for read... (`%s' for `%s')"
  1550.             (database-sub-fieldsep-string database) fieldsep-orig)
  1551.         (goto-char (point-min))
  1552.         (replace-string fieldsep-orig (database-sub-fieldsep-string database))
  1553.         (db-message "Substituting field delimiter for read...done")
  1554.         ))
  1555.     (db-message "sub-fieldsep = %s" (database-sub-fieldsep-string database))
  1556.  
  1557.     (db-debug-message "database-substitute-for-read:  substitutions = %s"
  1558.               (database-substitutions database))
  1559.  
  1560.     (database-perform-substitutions database t)
  1561.     ))))
  1562.  
  1563.  
  1564. ;; Perhaps have an optional argument which causes this to ignore problems
  1565. ;; with ambiguities.
  1566. (defun database-perform-substitutions (database backward)
  1567.   (if (database-substitutions database)
  1568.       (progn
  1569.     (db-debug-message "Substituting %s" (database-substitutions database))
  1570.     (db-message "Substituting...")
  1571.     (let ((ambiguities (buffer-substitute
  1572.                 (database-substitutions database) backward t)))
  1573.       (if ambiguities
  1574.           (error "Ambiguities:  %s" ambiguities)))
  1575.     (db-message "Substituting...done"))))
  1576.  
  1577.  
  1578. ;; Database-substitute-for-write does the substitution, then, if field
  1579. ;; separators were changed in order to prevent them from getting damaged by
  1580. ;; the substitution, converts them back to the user-specified strings,
  1581. ;; which might contain substrings that would have been substituted for in
  1582. ;; the previous operation, had we not been careful.
  1583. (defun database-substitute-for-write (database new-fieldsep sub-fieldsep
  1584.                            new-recordsep sub-recordsep)
  1585.   ;; Check that there are the correct number of fieldseps and recordseps
  1586.   ;; here; if wrong number, choose new fieldsep and/or recordsep and take
  1587.   ;; it from the top.
  1588.   ;; Or will that have been done beforehand?
  1589.  
  1590.   (db-debug-message "database-substitute-for-write: %s %s %s %s"
  1591.             (prin1-to-string new-fieldsep)
  1592.             (prin1-to-string sub-fieldsep)
  1593.             (prin1-to-string new-recordsep)
  1594.             (prin1-to-string sub-recordsep))
  1595.  
  1596.   (db-debug-message "database-substitute-for-write:  substitutions = %s"
  1597.             (database-substitutions database))
  1598.   (db-debug-message "database-substitute-for-write:  about to call database-perform-substitutions")
  1599.  
  1600.   (database-perform-substitutions database nil)
  1601.  
  1602.   (if (not (equal sub-fieldsep new-fieldsep))
  1603.       (progn
  1604.     (db-debug-message "replacing fieldsep")
  1605.     (goto-char (point-min))
  1606.     (replace-string sub-fieldsep new-fieldsep)))
  1607.   (if (not (equal sub-recordsep new-recordsep))
  1608.       (progn
  1609.     (db-debug-message "replacing recordsep")
  1610.     (goto-char (point-min))
  1611.     (replace-string sub-recordsep new-recordsep)))
  1612.  
  1613.   ;; Now the buffer is ready to have the preceding and trailing junk
  1614.   ;; added and to be written to disk.
  1615.   )
  1616.  
  1617.  
  1618.  
  1619. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1620. ;;; Substitution Utilities
  1621. ;;;
  1622.  
  1623.  
  1624. ;; Remember that the separators used when reading worked, and if they still
  1625. ;; pass the substitution test, use them again when writing.
  1626. ;; [Do this via a database slot.]
  1627.  
  1628.  
  1629. ;; If there are no conflicts, these can be set to their usual values and
  1630. ;; everything is happy.  Otherwise...
  1631.  
  1632.  
  1633. ;; Maybe get rid of "database-" from the name of this function.
  1634.  
  1635. ;; Is there a better way (ie, fewer false alarms) of checking whether a
  1636. ;; separator is OK (wrt substitution) than checking each character
  1637. ;; individually?
  1638.  
  1639. ;; If the seps are strings, I can test whether an overlapping match is
  1640. ;; possible by testing whether each prefix of the string is a suffix.  (Do
  1641. ;; I need to cross-test both of them?)  If I could show that overlaps are
  1642. ;; impossible, I could use how-many (or how-many-string, etc.) directly.
  1643.  
  1644. ;;; This is wrong:  I always get it right the first time around, because I
  1645. ;;; check for substitution conflicts.
  1646. ;; If I've been too generous about the recordsep (ie, I know the fieldsep
  1647. ;; is not OK but it looks like the only problem is that there are too many
  1648. ;; fieldseps), then I can always catch it the next time around...when
  1649. ;; reading, I always get it on the first try.
  1650.  
  1651. ;; Return a list of (fieldsep-bad-p recordsep-bad-p no-of-records), aka a
  1652. ;; conflist.  Useful both when reading and when writing.  (When reading,
  1653. ;; database-no-of-records should be nil.)
  1654. (defmacro conflist-fieldsep-bad-p (conflist) (` (car (, conflist))))
  1655. (defmacro conflist-recordsep-bad-p (conflist) (` (car (cdr (, conflist)))))
  1656. (defmacro conflist-no-of-records (conflist) (` (car (cdr (cdr (, conflist))))))
  1657.  
  1658. ;; This assumes that recordsep appears at the end of the database as well.
  1659.  
  1660. (defun database-confirm-fieldsep-and-recordsep (fieldsep recordsep no-of-fields no-of-records)
  1661.   (let* ((fieldsep-matches (progn (goto-char (point-min))
  1662.                   (how-many-string-overlapping fieldsep)))
  1663.      (recordsep-matches (progn (goto-char (point-min))
  1664.                    (how-many-string-overlapping recordsep)))
  1665.      (goal-fieldsep-matches (and no-of-records
  1666.                      (* no-of-records
  1667.                     (1- no-of-fields))))
  1668.      (goal-recordsep-matches no-of-records))
  1669.     ;; Possibly even this can be merged into the main body.
  1670.     ;; But keeping it separate might save some computation and special-casing.
  1671.     (if (equal fieldsep recordsep)
  1672.     (progn
  1673.       (db-debug-message "database-confirm-fieldsep-and-recordsep:  fieldsep = recordsep")
  1674.       (db-debug-message "   fm = %s, rm = %s, gfm = %s, grm = %s, nof = %s, nor = %s"
  1675.            fieldsep-matches recordsep-matches
  1676.            goal-fieldsep-matches goal-recordsep-matches
  1677.            no-of-fields no-of-records)
  1678.      
  1679.       (if no-of-records
  1680.           (if (= recordsep-matches (+ goal-recordsep-matches
  1681.                       goal-fieldsep-matches))
  1682.           (list nil nil no-of-records)
  1683.         (list t t nil))
  1684.         ;; Remember that fieldsep = recordsep when reading this code.
  1685.         (if (zerop (% recordsep-matches no-of-fields))
  1686.         (list nil nil (/ recordsep-matches no-of-fields))
  1687.           (if (zerop (% (1+ recordsep-matches) no-of-fields))
  1688.           ;; A field separator at the end of the data was misinterpreted
  1689.           ;; as a record separator, so no record separator was added.
  1690.           (progn (goto-char (point-max))
  1691.              (insert recordsep)
  1692.              (list nil nil (/ (1+ recordsep-matches) no-of-fields)))
  1693.         (list t t (/ recordsep-matches no-of-fields))))))
  1694.       ;; fieldsep and recordsep unequal; see if one is a substring of the other.
  1695.      
  1696.       ;; At least one of these must be zero.
  1697.       (let ((f-in-r (how-many-substring-overlapping fieldsep recordsep))
  1698.         (r-in-f (how-many-substring-overlapping recordsep fieldsep)))
  1699.     (db-debug
  1700.      (db-debug-message "database-confirm-fieldsep-and-recordsep:")
  1701.      (db-debug-message "   fm = %s, rm = %s, gfm = %s, grm = %s, nof = %s, nor = %s, f-in-r = %s, r-in-f = %s"
  1702.           fieldsep-matches recordsep-matches
  1703.           goal-fieldsep-matches goal-recordsep-matches
  1704.           no-of-fields no-of-records
  1705.           f-in-r r-in-f)
  1706.      )
  1707.  
  1708.     (if no-of-records
  1709.         (progn
  1710.           ;; at most one of these is nonzero, so cond is OK.
  1711.           (cond ((> f-in-r 0)
  1712.              (setq goal-fieldsep-matches
  1713.                (+ goal-fieldsep-matches
  1714.                   (* goal-recordsep-matches f-in-r))))
  1715.             ((> r-in-f 0)
  1716.              (setq goal-recordsep-matches
  1717.                (+ goal-recordsep-matches
  1718.                   (* goal-fieldsep-matches r-in-f)))))
  1719.           (list (not (= fieldsep-matches goal-fieldsep-matches))
  1720.             (not (= recordsep-matches goal-recordsep-matches))
  1721.             no-of-records))
  1722.       (progn
  1723.         (setq no-of-fields (+ no-of-fields f-in-r))
  1724.         (let ((apparent-records (/ fieldsep-matches (1- no-of-fields))))
  1725.           (setq goal-recordsep-matches
  1726.             (if (zerop apparent-records)
  1727.             1
  1728.               (* apparent-records
  1729.              (1+ (* r-in-f fieldsep-matches)))))
  1730.           (db-debug
  1731.            (db-debug-message "database-confirm-fieldsep-and-recordsep:  ar = %d, grm = %d, nof = %d"
  1732.             apparent-records goal-recordsep-matches no-of-fields))
  1733.           (list (or
  1734.              ;; Wrong number of fields:  some record has too many or too few.
  1735.              ;; This clause equivalent to:
  1736.              ;; (not (zerop (% fieldsep-matches (1- no-of-fields))))
  1737.              ;; which is more efficient?
  1738.              (not (= fieldsep-matches (* apparent-records
  1739.                          (1- no-of-fields))))
  1740.              ;; too many fieldseps compared to recordseps
  1741.              (< recordsep-matches goal-recordsep-matches))
  1742.             ;; too many recordseps compared to fieldseps
  1743.             (< goal-recordsep-matches recordsep-matches)
  1744.             apparent-records))))))
  1745.     ))
  1746.  
  1747.  
  1748.  
  1749. ;; Note that this is global; hope we only write/read one database at a
  1750. ;; time.  It should be nilled out before starting to read/write a database.
  1751. ;; Maybe don't bother with this and go searching down the substitutions
  1752. ;; list (which won't be very long, typically) as is.  Maybe use a big
  1753. ;; vector (one elt per character) to show which characters are OK.  Maybe
  1754. ;; I'm worrying too much about this little issue.
  1755.  
  1756. (defvar db-substitution-no-no-string nil)
  1757.  
  1758. ;; Calling this repeatedly could be slow because of repeated computation of
  1759. ;; substitution-no-no-string; maybe compute it (or, better, nil it out; can
  1760. ;; check and set if need be) at the beginning of reading/writing.
  1761.  
  1762. ;; Get rid of database argument.
  1763.  
  1764. ;; Return t iff no characters of delimiter appear in substitution-no-no-string.
  1765. (defun database-acceptable-delimiter-p (delimiter)
  1766.   (if delimiter
  1767.       (let ((result t)
  1768.         (string-index 0)
  1769.         (delimiter-length (length delimiter)))
  1770.     (while (and result (< string-index delimiter-length))
  1771.       (if (find-char (elt delimiter string-index)
  1772.              db-substitution-no-no-string)
  1773.           (setq result nil)
  1774.         (setq string-index (1+ string-index))))
  1775.     result)))
  1776.  
  1777. ;; call this in the write buffer.
  1778. (defun database-generate-delimiter (database &optional check-buffer)
  1779.   (let ((string (make-string 1 0))
  1780.     (candidate-char 0)
  1781.     result)
  1782.     (while (and (< candidate-char 256) (not result))
  1783.       (aset string 0 candidate-char)
  1784.       (if (and (database-acceptable-delimiter-p string)
  1785.            (not (and check-buffer
  1786.              (progn
  1787.                (goto-char (point-min))
  1788.                (search-forward string nil t))))
  1789.            (not (find-char candidate-char
  1790.                    (or (database-sub-fieldsep-string database)
  1791.                    (database-full-fieldsep-string database))))
  1792.            (not (find-char candidate-char
  1793.                    (or (database-sub-recordsep-string database)
  1794.                    (database-full-recordsep-string database)))))
  1795.       (setq result string)
  1796.     (setq candidate-char (1+ candidate-char))))
  1797.     (or result
  1798.     (error "I can't find an acceptable delimiter!"))))
  1799.  
  1800.  
  1801. (defun database-set-temp-delimiters (database db-buffer)
  1802.   ;; DB-BUFFER is only set if this is for reading.
  1803.   ;; (Well, for writing I'm only going to call this if there was some
  1804.   ;; sort of trouble and I need to recompute from the database buffer,
  1805.   ;; so I suspect that DB-BUFFER will always be set.  Maybe just use
  1806.   ;; the current buffer.)
  1807.  
  1808.  
  1809.   ;; If reading, we have to trust that there are only the correct number
  1810.   ;; of field delimiters currently in the buffer.
  1811.  
  1812.  
  1813.  
  1814.  
  1815.   )
  1816.  
  1817.  
  1818. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1819. ;;; Quotation
  1820. ;;;
  1821.  
  1822. (defun db-set-field-quotation-vars (database)
  1823.   (let ((quotation-char (database-quotation-char database)))
  1824.     (if (stringp quotation-char)
  1825.     (let ((quot-char-len (length quotation-char)))
  1826.       (cond ((= 0 quot-char-len)
  1827.          (setq quotation-char nil))
  1828.         ((= 0 quot-char-len)
  1829.          (setq quotation-char (elt quotation-char 1)))
  1830.         (t
  1831.          (error "Quotation character should be just that, not some rambling string like `%s'." quotation-char)))
  1832.       (database-set-quotation-char database quotation-char)))
  1833.     (if quotation-char
  1834.     (progn
  1835.       (database-set-quotation-char-regexp database
  1836.           (regexp-quote (char-to-string (database-quotation-char database))))
  1837.       (database-set-actual-quoted-regexp database
  1838.           (or (database-quoted-regexp database)
  1839.           (mapconcat (function regexp-quote)
  1840.                  (sort (or (database-quoted-strings database)
  1841.                        (quoted-strings-default database))
  1842.                    (function string-longer-p-function))
  1843.                  "\\|")))))))
  1844.  
  1845. ;; There are so many things that this could be dependent on (including all
  1846. ;; the strings in all the sepinfos) that I have a hidden variable here.
  1847. ;; This ensures that all the proper changes get propagated to the proper
  1848. ;; places.  (Say that ten times fast.)
  1849.  
  1850.  
  1851. ;; (set-field-quotation-vars '("foo" "bar" "f" "foobar" "[]"))
  1852.  
  1853. ;; This could be inefficient:  since it will be called repeatedly, it would
  1854. ;; be nice not to have to check database-quotation-character and other
  1855. ;; database slots all the time.
  1856.  
  1857. ;; One possibility is to put it all in a buffer (say, different fields on
  1858. ;; different lines) and do a replace-regexp, then cons it all up.  But then
  1859. ;; again, I expect there to be very little quoting in general, and that
  1860. ;; sounds like a painful solution.
  1861.  
  1862. (defun field-quote (fieldvalue database)
  1863.   (if (and (database-quotation-char database)
  1864.        (string-match (database-quoted-regexp database) fieldvalue))
  1865.       (concat (substring fieldvalue 0 (match-beginning 0))
  1866.           (database-quotation-char database)
  1867.           (substring fieldvalue (match-beginning 0) (match-end 0))
  1868.           (field-quote (substring fieldvalue (match-end 0)) database))
  1869.     fieldvalue))
  1870.  
  1871. ;; Is this use of actual-quoted-regexp correct?
  1872. (defun field-unquote (fieldvalue database)
  1873.   (if (database-quotation-char database)
  1874.       (let ((i (string-match (database-quotation-char-regexp database)
  1875.                  fieldvalue)))
  1876.     (if i
  1877.         (if (= (1+ i) (string-match (database-actual-quoted-regexp database)
  1878.                     fieldvalue (1+ i)))
  1879.         (concat (substring fieldvalue 0 i)
  1880.             (substring fieldvalue (1+ i) (match-end 0))
  1881.             (field-unquote (substring fieldvalue (match-end 0))
  1882.                        database))
  1883.           (concat (substring fieldvalue 0 (1+ i))
  1884.               (field-unquote (substring fieldvalue (1+ i))
  1885.                      database)))
  1886.       fieldvalue))
  1887.     fieldvalue))
  1888.  
  1889. ;; Later on the result will probably get sorted by length, but I don't do it now.
  1890. (defun quoted-strings-default (database)
  1891.   (if (database-quotation-char database)
  1892.       (delq nil
  1893.         (list
  1894.          (sepinfo-pre-first-string (database-record-sepinfo database))
  1895.          (sepinfo-sep-string (database-record-sepinfo database))
  1896.          (sepinfo-post-last-string (database-record-sepinfo database))
  1897.         
  1898.          (sepinfo-pre-first-string (database-field-sepinfo database))
  1899.          (sepinfo-sep-string (database-field-sepinfo database))
  1900.          (sepinfo-post-last-string (database-field-sepinfo database))
  1901.         
  1902.          (sepinfo-pre-first-string (database-alternative-sepinfo database))
  1903.          (sepinfo-sep-string (database-alternative-sepinfo database))
  1904.          (sepinfo-post-last-string (database-alternative-sepinfo database))
  1905.         
  1906.          (char-to-string (database-quotation-char database))))))
  1907.  
  1908.  
  1909. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1910. ;;; Random useful functions
  1911. ;;;
  1912.  
  1913. ;; A sep-function for records with n lines.
  1914. (defun record-sep-lines-function (n)
  1915.   (` (lambda (post-last-item-pos)
  1916.          (next-line (, n))
  1917.          (let ((here (point)))    
  1918.            (cons (1- here)
  1919.              (if (< here post-last-item-pos)
  1920.                  here))))))
  1921.  
  1922.  
  1923. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1924. ;;; Stuff
  1925. ;;;
  1926.  
  1927.  
  1928. ;; I don't want to have to use how-many-*-overlapping because I ought to
  1929. ;; have been smarter than that in choosing my field separators (such that
  1930. ;; there's no overlap).  But, on the other hand, it is possible that after
  1931. ;; all is said and done and I've replaced the actual for the generated
  1932. ;; separator strings, then ambiguities arise.  Eg, if one field ends "ab"
  1933. ;; and the actual separator string is "aba".  This seems to imply that
  1934. ;; quoting alone is insufficient (unless I decided to quote single
  1935. ;; characters; yes, that's the right thing to do).
  1936.  
  1937. ;; [As mentioned elsewhere, this is a danger if (?? and only if ??) some
  1938. ;; prefix of the separator is a suffix of the separator.  (?? Check only
  1939. ;; within wone separator, or check both?  Overlapping has nothing to do
  1940. ;; with having characters in common with substitutions, however; it is
  1941. ;; after substituting in that ambiguities may arise.  The only solution for
  1942. ;; them is quoting, or substitution out of any possible ambiguities (ie,
  1943. ;; substitution for every character of, or at least first and last
  1944. ;; characters of, separators); this is feasible if separators are small,
  1945. ;; but totherwise? ??)
  1946.  
  1947.  
  1948. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  1949.  
  1950. ;; Quoting and substitution take too long (too many function calls, and too
  1951. ;; much work usually for naught, too much garbage creation) when called on
  1952. ;; individual strings.  Don't want to put quoting/substitution in the s->a and
  1953. ;; a->s functions (and in the constraint functions) because of the burden on
  1954. ;; the user, even though that would amortize the time for this operation
  1955. ;; (check each time a field is changed) and speed quoting/substitution (call
  1956. ;; it only on the fields that might need it); besides, if it was called on
  1957. ;; many fields, using s->a and a->s still results in many function calls.
  1958. ;;
  1959. ;; So do quoting and substitution on the database when it's in a buffer.
  1960. ;;
  1961. ;; Don't do them by record or by field, even though that would guarantee that
  1962. ;; we didn't munge the separators, because it would be too slow, even in the
  1963. ;; database buffer.
  1964. ;;
  1965. ;; If q/s won't munge the separators (look at the substitutions about to be
  1966. ;; done), then great.  Otherwise use some characters that are guaranteed to be
  1967. ;; ok as field and record separators.  When reading, read from disk, replace
  1968. ;; the actual separators by these characters, do quoting/substitution, and
  1969. ;; then parse the database using the generated characters.  When writing,
  1970. ;; write to a buffer with the characters, do quoting/substitution, replace the
  1971. ;; charcters with the real delimiters, and finally write to disk.
  1972. ;;
  1973. ;;
  1974. ;;
  1975. ;; Have variables that control whether the separator characters are allowed in
  1976. ;; the database; if no, add that to the constraint function for every field.
  1977. ;; (Of course, this works only if display and stored representations are the
  1978. ;; same; if they're different, then I'd have to call actual->stored just to
  1979. ;; check this.)
  1980. ;;
  1981. ;;
  1982. ;;   [Only worry is that then something
  1983. ;; will come out of the last field badly; perhaps insert an extra field
  1984. ;; delimiter right before the record delimiter.  Yes, that would make things
  1985. ;; easy for me.  But that sort of goes against the grain of what I want to do.]
  1986. ;;
  1987. ;;
  1988. ;;   Now, the real whole point of this was to permit a wide variety of
  1989. ;; formats.  But that's only useful if the formats are easy to read.  Is
  1990. ;; quoting, which changes the field value, really going to make it easier to
  1991. ;; read?  One should be able to tell where fields start and end... (actually,
  1992. ;; I think quoting *does* help with that).
  1993. ;;   Furthermore, my functions only work if the fields are regular (well,
  1994. ;; describable by regexps for reading in and by strings for writing out).
  1995. ;; More complicated formats will need to have a custom Lisp function for
  1996. ;; reading/writing anyway, so don't sweat too much over them.
  1997. ;;   The real problem, then, is substituting for the field separator
  1998. ;; character(s).  If the field separator is multi-char, we only need to make
  1999. ;; sure that one character in any match is substituted for.
  2000. ;;   Or I could deal with the field separator character specially and disallow
  2001. ;; it in the general checking function.
  2002. ;;   To try to write my own replace-one-char-by-one-char that's more efficient
  2003. ;; than replace-string is lunacy.  [Or is it?  Search-forward, delete char,
  2004. ;; insert char ought to be quicker than than serach-forward, replace-match.]
  2005. ;;
  2006. ;;   How to devise the characters (or even strings, if I so choose) of my
  2007. ;; devising?  If they're in the text, I lose.  I guess I have to check for
  2008. ;; them all the time; but they might be in the actual or display rep and not
  2009. ;; in the stored rep, or vice-versa.  So only check for string types, mayhap.
  2010. ;;   Have a variable:  if set, then check for the char.  Do this via
  2011. ;; count-occurrences.  [Always do this; it won't be so terribly expensive.]
  2012. ;;   There need only be one special char (ie, not one for field and another
  2013. ;; for record) if my replace-one-char-by-one-char takes a repetition count and
  2014. ;; I call it repeatedly; but I don't particularly want that many function
  2015. ;; calls.  So make it a defsubst or something.
  2016. ;;
  2017. ;; The plan for writing:
  2018. ;;   Have a variable which controls whether to use a generated character (and
  2019. ;; if so, which one, unless it's t, in which case try to find one, by trying
  2020. ;; something, and if it doesn't work looking for a character that doesn't
  2021. ;; appear; probably try again in any case if failure).  [Maybe figure this out
  2022. ;; by looking at the substitutions; though if quoting is used instead (should
  2023. ;; I still have quoting at all?), then the substitutions tell me nothing.]  If
  2024. ;; not using a generated character, then either use the field separator
  2025. ;; throughout (can substitute in at record boundaries later on) or use both
  2026. ;; the field and record separators.  Choosing a generated character:
  2027. ;; shoudln't be in either side of any substitution stuff.  Shouldn't be
  2028. ;; quotation character.
  2029. ;;   write fields one after the other using this character only to separate
  2030. ;; them.
  2031. ;;   check whether there are too many of the character or just the right
  2032. ;; number.
  2033. ;;   do substitution
  2034. ;;   substitute for the separator character.
  2035. ;;
  2036. ;; Do I want to permit regexps instead of strings as separators?  Do I want to
  2037. ;; permit multi-char strings as separators?
  2038.  
  2039. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  2040.  
  2041. ;; It may be necessary as a last resort to call quoting/substitution on
  2042. ;; fields individually if every character appears in the database file
  2043. ;; representation.  In this case substitution *will* lose information.
  2044. ;; What a nightmare!
  2045.  
  2046. ;; When doing substitution, warn if information is about to be lost.  (ie,
  2047. ;; if target appears in database).
  2048.  
  2049. ;;; db-file-io.el ends here
  2050.