+ '(lsdb-font-lock-keywords t)))
+ (make-local-hook 'post-command-hook)
+ (add-hook 'post-command-hook 'lsdb-modeline-update nil t)
+ (make-local-variable 'lsdb-modeline-string)
+ (setq mode-line-buffer-identification
+ (lsdb-modeline-buffer-identification
+ '("LSDB: " lsdb-modeline-string)))
+ (lsdb-modeline-update)
+ (force-mode-line-update))
+
+(defun lsdb-modeline-update ()
+ (let ((record
+ (get-text-property (if (eobp) (point-min) (point)) 'lsdb-record))
+ net)
+ (if record
+ (progn
+ (setq net (car (cdr (assq 'net (cdr record)))))
+ (if (and net (equal net (car record)))
+ (setq lsdb-modeline-string net)
+ (setq lsdb-modeline-string (concat (car record) " <" net ">"))))
+ (setq lsdb-modeline-string ""))))
+
+(defun lsdb-narrow-to-record ()
+ "Narrow to the current record."
+ (let ((end (next-single-property-change (point) 'lsdb-record nil
+ (point-max))))
+ (narrow-to-region
+ (previous-single-property-change end 'lsdb-record nil (point-min))
+ end)
+ (goto-char (point-min))))
+
+(defun lsdb-current-record ()
+ "Return the current record name."
+ (get-text-property (point) 'lsdb-record))
+
+(defun lsdb-delete-record (record)
+ "Delete given RECORD."
+ (lsdb-remhash (car record) lsdb-hash-table)
+ (run-hook-with-args 'lsdb-after-delete-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t))
+
+(defun lsdb-current-entry ()
+ "Return the current entry name in canonical form."
+ (save-excursion
+ (beginning-of-line)
+ (if (looking-at "^\t\\([^\t][^:]+\\):")
+ (intern (downcase (match-string 1))))))
+
+(defun lsdb-read-entry (record &optional prompt)
+ "Prompt to select an entry in the given RECORD."
+ (let* ((completion-ignore-case t)
+ (entry-name
+ (completing-read
+ (or prompt
+ "Which entry: ")
+ (mapcar (lambda (entry)
+ (list (capitalize (symbol-name (car entry)))))
+ (cdr record))
+ nil t)))
+ (unless (equal entry-name "")
+ (intern (downcase entry-name)))))
+
+(defun lsdb-delete-entry (record entry)
+ "Delete given ENTRY from RECORD."
+ (setcdr record (delq entry (cdr record)))
+ (lsdb-puthash (car record) (cdr record)
+ lsdb-hash-table)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t))
+
+(defun lsdb-mode-add-entry (entry-name)
+ "Add an entry on the current line."
+ (interactive
+ (let ((completion-ignore-case t))
+ (list (completing-read "Entry name: " lsdb-known-entry-names))))
+ (beginning-of-line)
+ (unless (symbolp entry-name)
+ (setq entry-name (intern (downcase entry-name))))
+ (when (assq entry-name (cdr (lsdb-current-record)))
+ (error "The entry already exists"))
+ (let ((marker (point-marker)))
+ (lsdb-edit-form
+ nil "Editing the entry."
+ `(lambda (form)
+ (when form
+ (save-excursion
+ (set-buffer lsdb-buffer-name)
+ (goto-char ,marker)
+ (let ((record (lsdb-current-record))
+ (inhibit-read-only t)
+ buffer-read-only)
+ (setcdr record (cons (cons ',entry-name form) (cdr record)))
+ (lsdb-puthash (car record) (cdr record)
+ lsdb-hash-table)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t)
+ (beginning-of-line 2)
+ (add-text-properties
+ (point)
+ (progn
+ (lsdb-insert-entry (cons ',entry-name form))
+ (point))
+ (list 'lsdb-record record)))))))))
+
+(defun lsdb-mode-delete-entry-1 (entry)
+ "Delete text contents of the ENTRY from the current buffer."
+ (save-restriction
+ (lsdb-narrow-to-record)
+ (let ((case-fold-search t)
+ (inhibit-read-only t)
+ buffer-read-only)
+ (goto-char (point-min))
+ (if (re-search-forward
+ (concat "^\t" (capitalize (symbol-name (car entry))) ":")
+ nil t)
+ (delete-region (match-beginning 0)
+ (if (re-search-forward
+ "^\t[^\t][^:]+:" nil t)
+ (match-beginning 0)
+ (point-max)))))))
+
+(defun lsdb-mode-delete-entry ()
+ "Delete the entry on the current line."
+ (interactive)
+ (let ((record (lsdb-current-record))
+ entry-name entry)
+ (unless record
+ (error "There is nothing to follow here"))
+ (setq entry-name (or (lsdb-current-entry)
+ (lsdb-read-entry record "Which entry to delete: "))
+ entry (assq entry-name (cdr record)))
+ (when (and entry
+ (or (not lsdb-verbose)
+ (y-or-n-p
+ (format "Do you really want to delete entry `%s' of `%s'? "
+ entry-name (car record)))))
+ (lsdb-delete-entry record entry)
+ (lsdb-mode-delete-entry-1 entry))))
+
+(defun lsdb-mode-delete-record ()
+ "Delete the record on the current line."
+ (interactive)
+ (let ((record (lsdb-current-record)))
+ (unless record
+ (error "%s" "There is nothing to follow here"))
+ (when (or (not lsdb-verbose)
+ (yes-or-no-p
+ (format "Do you really want to delete entire record of `%s'? "
+ (car record))))
+ (lsdb-delete-record record)
+ (save-restriction
+ (lsdb-narrow-to-record)
+ (let ((inhibit-read-only t)
+ buffer-read-only)
+ (delete-region (point-min) (point-max)))))))
+
+(defun lsdb-mode-delete-entry-or-record ()
+ "Delete the entry on the current line.
+If the cursor is on the first line of a database entry (the name line)
+then the entire entry will be deleted."
+ (interactive)
+ (if (lsdb-current-entry)
+ (lsdb-mode-delete-entry)
+ (lsdb-mode-delete-record)))
+
+(defun lsdb-mode-edit-entry ()
+ "Edit the entry on the current line."
+ (interactive)
+ (let ((record (lsdb-current-record)))
+ (unless record
+ (error "There is nothing to follow here"))
+ (let ((entry-name (or (lsdb-current-entry)
+ (lsdb-read-entry record "Which entry to edit: "))))
+ (lsdb-edit-form
+ (cdr (assq entry-name (cdr record))) "Editing the entry."
+ `(lambda (form)
+ (let* ((record ',record)
+ (entry-name ',entry-name)
+ (entry (assq entry-name (cdr record))))
+ (unless (equal form (cdr entry))
+ (setcdr entry form)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t)
+ (with-current-buffer lsdb-buffer-name
+ (let ((inhibit-read-only t)
+ buffer-read-only
+ (pos (text-property-any (point-min) (point-max)
+ 'lsdb-record record)))
+ (unless pos
+ (error "%s" "The entry currently in editing is discarded"))
+ (lsdb-mode-delete-entry-1 entry)
+ (forward-line 0)
+ (add-text-properties
+ (point)
+ (progn
+ (lsdb-insert-entry (cons entry-name form))
+ (point))
+ (list 'lsdb-record record)))))))))))
+
+(defun lsdb-mode-edit-record ()
+ "Edit the name of the record on the current line."
+ (interactive)
+ (let ((record (lsdb-current-record)))
+ (unless record
+ (error "There is nothing to follow here"))
+ (lsdb-edit-form
+ (car record) "Editing the name."
+ `(lambda (new-name)
+ (unless (stringp new-name)
+ (error "String is required: `%s'" new-name))
+ (let* ((record ',record)
+ (old-name (car record)))
+ (unless (equal new-name old-name)
+ (lsdb-delete-record record)
+ (setcar record new-name)
+ (lsdb-puthash new-name (cdr record) lsdb-hash-table)
+ (run-hook-with-args 'lsdb-after-update-record-functions record)
+ (setq lsdb-hash-tables-are-dirty t)
+ (with-current-buffer lsdb-buffer-name
+ (let ((inhibit-read-only t)
+ buffer-read-only
+ (pos (text-property-any (point-min) (point-max)
+ 'lsdb-record record)))
+ (unless pos
+ (error "%s" "The entry currently in editing is discarded"))
+ (delete-region (point) (+ (point) (length old-name)))
+ (add-text-properties (point)
+ (progn (insert form) (point))
+ (list 'lsdb-record record))))))))))
+
+(defun lsdb-mode-edit-entry-or-record ()
+ "Edit the entry on the current line.
+If the cursor is on the first line of a database entry (the name line)
+then the name of this record will be edited."
+ (interactive)
+ (if (lsdb-current-entry)
+ (lsdb-mode-edit-entry)
+ (lsdb-mode-edit-record)))
+
+(defun lsdb-mode-save (&optional dont-ask)
+ "Save LSDB hash table into `lsdb-file'."
+ (interactive (list t))
+ (if (not lsdb-hash-tables-are-dirty)
+ (message "(No changes need to be saved)")
+ (when (or dont-ask
+ (not lsdb-verbose)
+ (y-or-n-p "Save the LSDB now? "))
+ (lsdb-save-hash-tables)
+ (set-buffer-modified-p (setq lsdb-hash-tables-are-dirty nil))
+ (message "The LSDB was saved successfully."))))
+
+(defun lsdb-mode-load ()
+ "Load LSDB hash table from `lsdb-file'."
+ (interactive)
+ (let (lsdb-secondary-hash-tables)
+ (lsdb-load-hash-tables))
+ (message "Rebuilding secondary hash tables...")
+ (lsdb-rebuild-secondary-hash-tables t)
+ (message "Rebuilding secondary hash tables...done"))
+
+(defun lsdb-mode-quit-window (&optional kill window)
+ "Quit the current buffer.
+It partially emulates the GNU Emacs' of `quit-window'."
+ (interactive "P")
+ (unless window
+ (setq window (selected-window)))
+ (let ((buffer (window-buffer window)))
+ (unless (save-selected-window
+ (select-window window)
+ (one-window-p))
+ (delete-window window))
+ (if kill
+ (kill-buffer buffer)
+ (bury-buffer (unless (eq buffer (current-buffer)) buffer)))))
+
+(defun lsdb-hide-buffer ()
+ "Hide the LSDB window."
+ (let ((window (get-buffer-window lsdb-buffer-name)))
+ (if window
+ (lsdb-mode-quit-window nil window))))
+
+(defun lsdb-show-buffer ()
+ "Show the LSDB window."
+ (if (get-buffer lsdb-buffer-name)
+ (if lsdb-temp-buffer-show-function
+ (let ((lsdb-pop-up-windows t))
+ (funcall lsdb-temp-buffer-show-function lsdb-buffer-name))
+ (pop-to-buffer lsdb-buffer-name))))
+
+(defun lsdb-toggle-buffer (&optional arg)
+ "Toggle hiding of the LSDB window.
+If given a negative prefix, always show; if given a positive prefix,
+always hide."
+ (interactive
+ (list (if current-prefix-arg
+ (prefix-numeric-value current-prefix-arg)
+ 0)))
+ (unless arg ;called noninteractively?
+ (setq arg 0))
+ (cond
+ ((or (< arg 0)
+ (and (zerop arg)
+ (not (get-buffer-window lsdb-buffer-name))))
+ (lsdb-show-buffer))
+ ((or (> arg 0)
+ (and (zerop arg)
+ (get-buffer-window lsdb-buffer-name)))
+ (lsdb-hide-buffer))))
+
+(defun lsdb-lookup-records (regexp &optional entry-name)
+ "Return the all records in the LSDB matching the REGEXP.
+If the optional 2nd argument ENTRY-NAME is given, matching only
+performed against the entry field."
+ (let (records)
+ (lsdb-maphash
+ (if entry-name
+ (progn
+ (lambda (key value)
+ (let ((entry (cdr (assq entry-name value)))
+ found)
+ (unless (listp entry)
+ (setq entry (list entry)))
+ (while (and (not found) entry)
+ (if (string-match regexp (pop entry))
+ (setq found t)))
+ (if found
+ (push (cons key value) records)))))
+ (lambda (key value)
+ (if (string-match regexp key)
+ (push (cons key value) records))))
+ lsdb-hash-table)
+ records))
+
+(defvar lsdb-mode-lookup-history nil)
+
+(defun lsdb-mode-lookup (regexp &optional entry-name)
+ "Display the all records in the LSDB matching the REGEXP.
+If the optional 2nd argument ENTRY-NAME is given, matching only
+performed against the entry field."
+ (interactive
+ (let* ((completion-ignore-case t)
+ (entry-name
+ (if current-prefix-arg
+ (completing-read "Entry name: "
+ lsdb-known-entry-names))))
+ (list
+ (read-from-minibuffer
+ (if entry-name
+ (format "Search records `%s' regexp: " entry-name)
+ "Search records regexp: ")
+ nil nil nil 'lsdb-mode-lookup-history)
+ (if (and entry-name (not (equal entry-name "")))
+ (intern (downcase entry-name))))))
+ (lsdb-maybe-load-hash-tables)
+ (let ((records (lsdb-lookup-records regexp entry-name)))
+ (if records
+ (lsdb-display-records records))))
+
+;;;###autoload
+(defalias 'lsdb 'lsdb-mode-lookup)
+
+(defun lsdb-mode-next-record (&optional arg)
+ "Go to the next record."
+ (interactive "p")
+ (unless arg ;called noninteractively?
+ (setq arg 1))
+ (if (< arg 0)
+ (lsdb-mode-previous-record (- arg))
+ (while (> arg 0)
+ (goto-char (next-single-property-change
+ (point) 'lsdb-record nil (point-max)))
+ (setq arg (1- arg)))))
+
+(defun lsdb-mode-previous-record (&optional arg)
+ "Go to the previous record."
+ (interactive "p")
+ (unless arg ;called noninteractively?
+ (setq arg 1))
+ (if (< arg 0)
+ (lsdb-mode-next-record (- arg))
+ (while (> arg 0)
+ (goto-char (previous-single-property-change
+ (point) 'lsdb-record nil (point-min)))
+ (setq arg (1- arg)))))
+
+;;;_ : Edit Forms -- stolen (and renamed) from gnus-eform.el
+(defvar lsdb-edit-form-buffer "*LSDB edit form*")
+(defvar lsdb-edit-form-done-function nil)
+(defvar lsdb-previous-window-configuration nil)
+
+(defvar lsdb-edit-form-mode-map
+ (let ((keymap (make-sparse-keymap)))
+ (set-keymap-parent keymap emacs-lisp-mode-map)
+ (define-key keymap "\C-c\C-c" 'lsdb-edit-form-done)
+ (define-key keymap "\C-c\C-k" 'lsdb-edit-form-exit)
+ keymap)
+ "Edit form's keymap.")
+
+(defun lsdb-edit-form-mode ()
+ "Major mode for editing forms.
+It is a slightly enhanced emacs-lisp-mode.
+
+\\{lsdb-edit-form-mode-map}"
+ (interactive)
+ (kill-all-local-variables)
+ (setq major-mode 'lsdb-edit-form-mode
+ mode-name "LSDB Edit Form")
+ (use-local-map lsdb-edit-form-mode-map)
+ (make-local-variable 'lsdb-edit-form-done-function)
+ (make-local-variable 'lsdb-previous-window-configuration)
+ (run-hooks 'lsdb-edit-form-mode-hook))
+
+(defun lsdb-edit-form (form documentation exit-func)
+ "Edit FORM in a new buffer.
+Call EXIT-FUNC on exit. Display DOCUMENTATION in the beginning
+of the buffer."
+ (let ((window-configuration
+ (current-window-configuration)))
+ (switch-to-buffer (get-buffer-create lsdb-edit-form-buffer))
+ (lsdb-edit-form-mode)
+ (setq lsdb-previous-window-configuration window-configuration
+ lsdb-edit-form-done-function exit-func)
+ (erase-buffer)
+ (insert documentation)
+ (unless (bolp)
+ (insert "\n"))
+ (goto-char (point-min))
+ (while (not (eobp))
+ (insert ";;; ")
+ (forward-line 1))
+ (insert ";; Type `C-c C-c' after you've finished editing.\n")
+ (insert "\n")
+ (let ((p (point)))
+ (pp form (current-buffer))
+ (insert "\n")
+ (goto-char p))))
+
+(defun lsdb-edit-form-done ()
+ "Update changes and kill the current buffer."
+ (interactive)
+ (goto-char (point-min))
+ (let ((form (condition-case nil
+ (read (current-buffer))
+ (end-of-file nil)))
+ (func lsdb-edit-form-done-function))
+ (lsdb-edit-form-exit)
+ (funcall func form)))
+
+(defun lsdb-edit-form-exit ()
+ "Kill the current buffer."
+ (interactive)
+ (let ((window-configuration lsdb-previous-window-configuration))
+ (kill-buffer (current-buffer))
+ (set-window-configuration window-configuration)))