(require (quote database)) (require (quote db-util)) (provide (quote db-rdb)) (defvar database) (defvar db-rdb-field-name-charset "a-zA-Z0-9_" "\ The characters allowed in an RDB field name (using regexp format sans \"[]\").") (defvar db-rdb-list-separator-string " | " "\ The string that separates field names from values.") (defvar db-rdb-list-entry-regexp (concat "[ ]*\\([" db-rdb-field-name-charset "]*\\)" (regexp-quote db-rdb-list-separator-string) "[ ]*") "\ A regexp which matches the beginning of a List-format field entry, grouping the field name as \\1.") (defvar db-rdb-list-continuation-regexp "^[ ]*|[ ]+" "\ A regexp which matches the beginning of a List-format entry continuation.") (defvar db-rdb-list-continuation-output nil "\ A computed string used to identify and align continuation data.") (defvar db-rdb-rrfr-hooks nil "\ Hooks run on each database record before RDB parse.") (defvar db-rdb-wrfr-before-hooks nil "\ Hooks run before each RDB write of a database record. The record is bound to the dynamic variable record, and point is where the record will be inserted in the buffer.") (defvar db-rdb-wrfr-after-hooks nil "\ Hooks run after each RDB write of a database record. The record is bound to the dynamic variable record, and point is immediately after the file representation of the record.") (defvar db-rdb-converted-p nil "\ Non-nil if `database-stored->actual' has already been run.") (defvar db-rdb-file-type nil "\ Set to 'list or 'table by rdb-read-fields according to the type of the file. This is a database-local variable.") (defvar db-rdb-header-fields nil "\ Set to the list of header fields parsed by db-rdb-read-list-field-defs or db-rdb-read-table-field-defs.") (defvar db-rdb-field-defs nil "\ Set to the field definitions computed from the programmer-supplied field definitions and the RDB header field definitions.") (defvar db-rdb-header-string nil "\ Set to the header string, for either List or Table RDB files. This is used to rewrite the header when the database is updated.") (defvar db-buffer) (defun rdb-field-spec-handle (fspec) (byte-code "@" [fspec] 1)) (defun rdb-field-spec-name (fspec) (byte-code "@: @@@" [fspec] 1)) (defun rdb-field-spec-type (fspec) (byte-code "@: @A" [fspec] 1)) (defun rdb-field-spec-tag (fspec) (byte-code "A@" [fspec] 1)) (defun rdb-field-spec-help (fspec) (byte-code "AA@" [fspec] 1)) (proclaim-inline rdb-field-spec-handle rdb-field-spec-name rdb-field-spec-type rdb-field-spec-tag rdb-field-spec-help) (defun db-rdb-p (database) "\ Non-nil if DATABASE is in RDB file layout." (byte-code "#" [database t database-get-local db-rdb-field-defs] 4)) (proclaim-inline db-rdb-p) (defun db-rdb-setup (rdb-field-specs &optional lock-flag) "\ Ready the database to read files in RDB format. Creates database local variables and sets database slots. Argument RDB-FIELD-SPECS is a list of rdb-field specifications, one for each field in a database record. Optional, second argument LOCK-FLAG should be non-nil to lock the file for synchronized updates. The locking and unlocking is done with \"rdblock\" and \"rdbunlock\", which must be available in the current PATH environment variable. Each field specification is a three-element list of the field name (a symbol), the tag used to identify it in the file (a string), and a brief help string. Instead of a symbol, the rdb-field name may be a two-element list of the field name its type. To indicate that a field is never found in the input file (typically because it is computed on the fly), use nil for its tag." (byte-code "!#?# !" [database t rdb-field-specs db-rdb-p database-get-local db-rdb-converted-p database-set-local db-rdb-setup-internal] 6)) (defun db-rdb-setup-internal (field-specs) "\ Internal function to do the real work of `db-rdb-setup', without certain safety checks. This function should only be called once per database. Argument is the FIELD-SPECS (see db-rdb-setup)." (byte-code " H! \" $=&!m=m \"$\" P$II I I I I \"I\" K \"\" \"\"-" [db database rsi efields fspecs field-specs max-len t db-rdb-file-type db-rdb-list-separator-string db-default-field-type 17 db-rdb-read-fields db-rdb-correlate-field-defs 0 database-set-local db-rdb-field-defs table error "db-rdb-setup: table format not implemented yet!" list mapcar (lambda (fld) (byte-code " !G VG)" [tag fld max-len rdb-field-spec-tag] 3)) db-rdb-max-field-name-length db-rdb-continuation-output make-string 32 20 db-rdb-list-rrfr 21 db-rdb-list-wrfr 2 "\\`\\(\\([^ ]\\| [^ ]\\)* \\)" 3 1 4 " " 8 " " database-get-local db-rdb-header-string (lambda (fld) (byte-code " J#" [fld db database-make-local] 4)) (db-rdb-rrfr-hooks db-rdb-wrfr-before-hooks db-rdb-wrfr-after-hooks db-rdb-converted-p) nil-or-string database-set-fieldnames-to-list rdb-field-spec-handle (lambda (fspec) (byte-code " ! ! \" \"! H ( Q) I #-" [fn fspec help fnum db rs ohelp rdb-field-spec-name rdb-field-spec-help fieldname->fieldnumber copy-sequence database-recordfieldspec 8 " " database-set-recordfieldspec] 10)) db-add-to-hook db-after-read-hooks db-rdb-database-stored->actual] 17)) (defun db-rdb-database-stored->actual (&optional db) "\ Like `database-stored->actual', but only in RDB file layout." (byte-code " ! #?! #" [db database t db-rdb-p database-get-local db-rdb-converted-p database-stored->actual database-set-local] 7)) (defun db-rdb-list-rrfr nil "\ With the current buffer narrowed to a single RDB List record, parse it into field values." (byte-code " !\" !)ebm? !! ! # !`\"! !p !`\"Q!R Q$`!\"# ." [db database new-rec start-re cont-re fld-tag fld old-val fld-val hooks make-record "^[ ]*\\([a-zA-Z0-9_]*\\)[ ]*|[ ]*" "^[ ]*|[ ]*" nil database-get-local db-rdb-rrfr-hooks run-hooks looking-at db-match-string 1 db-rdb-lookup-field record-field end-of-line buffer-substring match-end 0 forward-line " " record-set-field error "This didn't look right to me (point = %s)" int-to-string] 23)) (defun db-rdb-list-wrfr (record) "\ Given an EDB RECORD, write convert to the RDB List format representation and write to the file." (byte-code " \"\"\"!)\"\"!\"!)+" [db database max-len contin before-hooks after-hooks database-get-local db-rdb-max-field-name-length db-rdb-continuation-output db-rdb-wrfr-before-hooks run-hooks mapcar (lambda (fld-def) (let ((fld-nam (rdb-field-spec-name fld-def)) (fld-tag (rdb-field-spec-tag fld-def))) (if (not (null fld-tag)) (let* ((fld-nbr (fieldname->fieldnumber fld-nam db)) (a->s (recordfieldspec-actual->stored (database-recordfieldspec db fld-nbr))) (fld-val (db-funcall-maybe a->s (aref record fld-nbr)))) (if (not (or (null fld-val) (equal "" fld-val))) (let ((fld-pad (- max-len (length fld-tag))) (i 0) j) (if (> fld-pad 0) (insert (make-string fld-pad 32))) (insert fld-tag " | ") (while (setq j (string-match " " fld-val i)) (insert (substring fld-val i j) " " contin) (setq i (+ j 1))) (insert (substring fld-val i) " "))))))) db-rdb-field-defs delete-char -1 db-rdb-wrfr-after-hooks] 10)) (defun db-rdb-lookup-field (tag) "\ Lookup FIELD-TAG in the RDB database field list, returning its associated NAME (a symbol)." (byte-code " \"# @A@\"@@A 4 :1 @N \" \" !B EC\" *" [field-list database sym nil tag database-get-local db-rdb-field-defs equal message "Field name % encountered, but not defined." nconc intern string-or-nil "Undefined field"] 10)) (defun db-rdb-read-fields (db) "\ In DATABASE, read the RDB-style headers, creating a list of field definitions, which is returned as the result." (byte-code "qeb!! !\" $ )" [db-buffer "Setup the field names from the current EDB database file, which is assumed to be formatted as an RDB database. The RDB database may be either in List format or Table form. Any updates will continue to maintain the RDB file in its current form. Any EDB format files for the database will be used automatically. The argument, FIELDDEFS, is a list of elements: ((SYMBOL FIELD-NAME FIELD-HELP)...). SYMBOL may itself be either an atom, a symbol, or a cons cell of (SYMBOL . TYPE). SYMBOL is used to identify the field by name in elisp code. TYPE, if given, must be a valid EDB fieldtype, either preconfigured, or user-defined. If TYPE is null or omitted, it will be deduced from the corresponding RDB header, utimately defaulting to \"string\". The FIELD-NAME is a string which must match one of the corresponding field names in the database. FIELD-NAMES which do not exist in the RDB file are shown in an error message, as are any unmentioned field names read from the RDB header. The FIELD-HELP is a string used for information when queried with \"?\" interactively. If FIELD-HELP is null, any comment in the field definition from the RDB file is used instead. Lastly, if FIELDDEFS is null, then all of the information will be obtained entirely from the RDB file, with the SYMBOL defaulting to the symbol with the same print-string as FIELD-NAME." looking-at "^#" forward-line 1 "^[ ]* " db-rdb-read-list-field-defs db-rdb-read-table-field-defs] 6)) (defun db-rdb-read-list-field-defs nil "\ Positioned at the blank line preceeding the field definitions in an RDB List file, read the field definitions and return them as an association list: ((FIELD-NAME FIELD-DEF FIELD-HELP)...)." (byte-code "!!?o!g!g!!! !! @ \"K \"! \"Y \" FC\"!!e`\"$$$މ." [fields name defn width help end database t db-rdb-file-type nil forward-line 1 looking-at "^[ ]*$" "^#" "^[ ]*\\(\\w+\\)[ ]+|[ ]+\\(.*\\)$" db-match-string db-string-split-first-word 2 car-safe cdr-safe string-match "\\([0-9]+\\)" string-to-int "\\([SNDM<>]\\)" append database-set-local db-rdb-header-string buffer-substring db-rdb-header-fields list] 25)) (defun db-rdb-correlate-field-defs (ifields efields) "\ Given INTERNAL-FIELDS and EXTERNAL-FIELDS, correlate the fields with each other and produce a field list suitable for M-x db-rdb-setup. INTERNAL-FIELDS is a list: ((HANDLE NAME HELP)...), where HANDLE is either (SYMBOL . TYPE) or just SYMBOL. EXTERNAL-FIELDS is a list: ((NAME WIDTH FORMAT HELP)...), produced by the function rdb-read-field-defs. If TYPE is omitted, it is deduced from the corresponding FORMAT. Similarly, if the internal HELP is omitted, any external HELP is used. The internal definition always overrides the external, since it is more specific to the EDB implementation. The resulting list format is: (((SYMBOL . TYPE) NAME HELP)...)." (byte-code " ? \" \" \" !?3 \"!?3 \"+" [fieldspec inames errs ifields efields nil 0 mapcar (lambda (edef) (byte-code " @!C)" [name edef intern] 2)) (lambda (idef) (byte-code " 8 8 8!@: A * \"   CC\" G?` \"!! T xx88 8  !B  E. " [handle idef name ihelp symbol type edef efields width format ehelp inames t errs 0 1 2 atom assoc nil append message "Internal field %s is not externally defined" beep sit-for 3 db-rdb-format-to-type] 10)) (lambda (edef) (byte-code " 8 \" ?\"! T*" [name edef idef inames errs 0 assoc message "External field %s is not defined internally." sit-for 3] 5)) zerop y-or-n-p format "%d errors occurred; continue? " error "db-rdb-setup: %d errors"] 9)) (defun db-rdb-format-to-type (format) "\ Given FORMAT from an RDB field definition, return an EDB record field TYPE." (byte-code "?\"\"łM\"\"łM\"-ȂM\"8\"?˂M\"!!Ň" [format t equal "S" "<" one-line-string ">" "N" integer-or-nil "D" "M" date-mmddyy message "Unknown field format: %s, string assumed" beep sit-for 3] 10)) (defun db-rdb-read-table-field-defs nil "\ Positioned at the field name line in an RDB Table file, read the field definitions and setup EDB for regular-file format. Leave the buffer positioned before the first record, if any." (byte-code " !$)" [db database t error "Not implemented yet." database-set-local db-rdb-file-type table] 6))