;;; my-bbdb.el -- Extensions for bbdb -*- lexical-binding: t -*-
;; Copyright (C) 2023 Free Software Foundation.
;; Author: Yuchen Pei <id@ypei.org>
;; Package-Requires: ((emacs "28.2"))
;; This file is part of dotfiles.
;; dotfiles is free software: you can redistribute it and/or modify it under
;; the terms of the GNU Affero General Public License as published by
;; the Free Software Foundation, either version 3 of the License, or
;; (at your option) any later version.
;; dotfiles is distributed in the hope that it will be useful, but WITHOUT
;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
;; or FITNESS FOR A PARTICULAR PURPOSE. See the GNU Affero General
;; Public License for more details.
;; You should have received a copy of the GNU Affero General Public
;; License along with dotfiles. If not, see <https://www.gnu.org/licenses/>.
;;; Commentary:
;; Extensions for bbdb.
;;; Code:
;; overrides bbdb-read-record in bbdb-com.el
(defun my-bbdb-read-record (&optional first-and-last)
"Read and return a new BBDB record.
Does not insert it into the database or update the hashtables,
but does ensure that there will not be name collisions."
(bbdb-editable)
(let ((record (bbdb-empty-record)))
;; name
(let (name)
(bbdb-error-retry
(setq name (bbdb-read-name first-and-last))
(bbdb-check-name (car name) (cdr name)))
(bbdb-record-set-firstname record (car name))
(bbdb-record-set-lastname record (cdr name)))
;; akas
(bbdb-record-set-aka record
(bbdb-split 'aka (bbdb-read-string "AKAs: ")))
;; urls
(bbdb-record-set-xfield record 'url (bbdb-read-string "urls: "))
;; mail
(bbdb-record-set-mail
record (bbdb-split 'mail (bbdb-read-string "E-Mail Addresses: ")))
;; notes
(bbdb-record-set-xfield record 'notes (bbdb-read-string "notes: "))
record))
;; overrides bbdb-create
;;;###autoload
(defun my-bbdb-create (record)
"Add a new RECORD to BBDB.
When called interactively read all relevant info.
Do not call this from a program; call `bbdb-create-internal' instead."
(interactive (list (bbdb-read-record current-prefix-arg)))
(bbdb-change-record record)
(bbdb-display-records (list record) nil nil t))
(defun my-bbdb-form (name)
"Insert or update a bbdb record using a form.
If NAME exists in bbdb, update. Otherwise insert."
(interactive
(list (completing-read "Name: " (mapcar 'bbdb-record-name (bbdb-records)))))
(let* ((record (or (car (bbdb-gethash name))
(bbdb-empty-record)))
(new-first-name) (new-last-name))
(switch-to-buffer-other-window "*Form BBDB*")
(kill-all-local-variables)
(let ((inhibit-read-only t)) (erase-buffer))
(remove-overlays)
(widget-insert "BBDB form\n\n")
(setq my-bbdb-widget-first-name
(widget-create 'editable-field :format "First Name: %v"
(or (bbdb-record-firstname record)
(car (bbdb-divide-name name)))))
(setq my-bbdb-widget-last-name
(widget-create 'editable-field :format "Last Name: %v"
(or (bbdb-record-lastname record)
(cdr (bbdb-divide-name name)))))
(setq my-bbdb-widget-aka
(widget-create 'editable-field
:format "Aliases: %v"
:value (bbdb-concat
'aka
(bbdb-record-aka record))))
(setq my-bbdb-widget-org
(widget-create 'editable-field
:format "Organisations: %v"
:value (bbdb-concat
'organization
(bbdb-record-organization record))))
(setq my-bbdb-widget-mail
(widget-create 'editable-field
:format "Email addresses: %v"
:value (bbdb-concat 'mail (bbdb-record-mail record))))
(widget-insert "Phone numbers\n")
(setq my-bbdb-widget-phone
(widget-create 'editable-list
:entry-format "%i %d %v"
:value
(mapcar (lambda (phone-info)
(list (aref phone-info 0)
(aref phone-info 1)))
(bbdb-record-phone record))
'(group
(menu-choice
:tag "Type"
(choice-item :value "cell")
(choice-item :value "work")
(choice-item :value "home")
(choice-item :value "other"))
(editable-field :format "number: %v" ""))))
(widget-create
'push-button
:notify (lambda (&rest _)
(setq new-first-name (widget-value my-bbdb-widget-first-name))
(setq new-last-name (widget-value my-bbdb-widget-last-name))
(unless (equal name
(bbdb-concat 'name-first-last new-first-name
new-last-name))
(bbdb-check-name new-first-name new-last-name))
(bbdb-record-set-name record new-first-name new-last-name)
(bbdb-record-set-organization
record (bbdb-split 'organization (widget-value my-bbdb-widget-org)))
(bbdb-record-set-mail
record (bbdb-split 'mail (widget-value my-bbdb-widget-mail)))
(bbdb-record-set-aka
record (bbdb-split 'aka (widget-value my-bbdb-widget-aka)))
(bbdb-record-set-phone
record (mapcar
(lambda (pair)
(vector (car pair) (cadr pair)))
(widget-value my-bbdb-widget-phone)))
(bbdb-change-record record)
(bbdb-display-records (list record) nil nil t))
"Submit"))
(use-local-map widget-keymap)
(widget-setup)
(goto-char (point-min)))
(defun my-bbdb-parse-record (record)
(list
(cons 'Name (bbdb-record-name record))
(cons 'First-name (bbdb-record-firstname record))
(cons 'Last-name (bbdb-record-lastname record))
(cons 'Organisation (car (bbdb-record-organization record)))
(cons 'Notes (bbdb-record-xfield record 'notes))
(cons 'Website (bbdb-record-xfield record 'url))))
(defun my-bbdb-insert-record-to-org (parsed)
(goto-char (point-min))
(insert "\n* "(alist-get 'Name parsed))
(insert "\n" (or
(and (alist-get 'Notes parsed)
(format "- %s" (alist-get 'Notes parsed)))
""))
(dolist (pair parsed)
(when (and (not (member (car pair) '(Name Notes))) (cdr pair))
(org-set-property (symbol-name (car pair)) (cdr pair)))))
(defun my--bbdb-to-org ()
"ONLY do this in a new buffer!"
(dolist (record (bbdb-records))
(my-bbdb-insert-record-to-org (my-bbdb-parse-record record))))
(defun my-bbdb-done ()
"Save and quit bbdb window"
(interactive)
(bbdb-save) (delete-window))
(defun my-bbdb-all ()
"Dispaly all bbdb records"
(interactive)
(bbdb ""))
(defun my-bbdb-clean-mail (address)
"Cleans email address."
(setq address (bbdb-string-trim address))
(cond ((string-match "\\`\\([^@+]+\\)\\+[^@]+\\(@.*\\)\\'" address)
(concat (match-string 1 address) (match-string 2 address)))
(t address)))
(provide 'my-bbdb)
;;; my-bbdb.el ends here